From b4fac6a0c4bb7bf4e0d31999ecdf4e43804f6a81 Mon Sep 17 00:00:00 2001 From: Andreas Jaeger Date: Sun, 8 Jun 2003 15:56:35 +0200 Subject: std.c: Remove #if 0'ed functions. * std.c: Remove #if 0'ed functions. * sta.c: Remove usage of HARD_F90, FFESTR_F90 and FFESTR_VXT. * stb.c: Likewise. * stb.h: Likewise. * stc.c: Likewise. * stc.h: Likewise. * std.c: Likewise. * std.h: Likewise. * ste.c: Likewise. * ste.h: Likewise. * str.h (FFESTR_F90): Remove macro. (FFESTR_VXT): Remove macro. From-SVN: r67625 --- gcc/f/ChangeLog | 15 + gcc/f/sta.c | 284 - gcc/f/stb.c | 24925 +++++++++++++++++++----------------------------------- gcc/f/stb.h | 78 +- gcc/f/stc.c | 14112 ++++++++++++------------------- gcc/f/stc.h | 128 +- gcc/f/std.c | 4330 +++------- gcc/f/std.h | 106 +- gcc/f/ste.c | 144 - gcc/f/ste.h | 22 - gcc/f/str.h | 7 +- 11 files changed, 15471 insertions(+), 28680 deletions(-) diff --git a/gcc/f/ChangeLog b/gcc/f/ChangeLog index ee65c0d..764fcad 100644 --- a/gcc/f/ChangeLog +++ b/gcc/f/ChangeLog @@ -1,5 +1,20 @@ 2003-06-08 Andreas Jaeger + * std.c: Remove #if 0'ed functions. + + * sta.c: Remove usage of HARD_F90, FFESTR_F90 and FFESTR_VXT. + * stb.c: Likewise. + * stb.h: Likewise. + * stc.c: Likewise. + * stc.h: Likewise. + * std.c: Likewise. + * std.h: Likewise. + * ste.c: Likewise. + * ste.h: Likewise. + + * str.h (FFESTR_F90): Remove macro. + (FFESTR_VXT): Remove macro. + * bld.c: Remove usage of FFETARGET_okCHARACTER2, FFETARGET_okCHARACTER3, FFETARGET_okCHARACTER4, FFETARGET_okCHARACTER5, FFETARGET_okCHARACTER6, diff --git a/gcc/f/sta.c b/gcc/f/sta.c index db3207f..765425a 100644 --- a/gcc/f/sta.c +++ b/gcc/f/sta.c @@ -592,29 +592,6 @@ ffesta_second_ (ffelexToken t) switch (ffesta_first_kw) { -#if FFESTR_VXT - case FFESTR_firstACCEPT: - ffesta_add_possible_exec_ ((ffelexHandler) ffestb_V019); - break; -#endif - -#if FFESTR_F90 - case FFESTR_firstALLOCATABLE: - ffestb_args.dimlist.len = FFESTR_firstlALLOCATABLE; - ffestb_args.dimlist.badname = "ALLOCATABLE"; - ffesta_add_possible_nonexec_ ((ffelexHandler) ffestb_dimlist); - break; -#endif - -#if FFESTR_F90 - case FFESTR_firstALLOCATE: - ffestb_args.heap.len = FFESTR_firstlALLOCATE; - ffestb_args.heap.badname = "ALLOCATE"; - ffestb_args.heap.ctx = FFEEXPR_contextALLOCATE; - ffesta_add_possible_exec_ ((ffelexHandler) ffestb_heap); - break; -#endif - case FFESTR_firstASSIGN: ffesta_add_possible_exec_ ((ffelexHandler) ffestb_R838); break; @@ -666,12 +643,6 @@ ffesta_second_ (ffelexToken t) ffesta_add_possible_nonexec_ ((ffelexHandler) ffestb_decl_gentype); break; -#if FFESTR_F90 - case FFESTR_firstCONTAINS: - ffesta_add_possible_exec_ ((ffelexHandler) ffestb_R1228); - break; -#endif - case FFESTR_firstCONTINUE: ffesta_add_possible_exec_ ((ffelexHandler) ffestb_R841); break; @@ -687,32 +658,6 @@ ffesta_second_ (ffelexToken t) ffesta_add_possible_nonexec_ ((ffelexHandler) ffestb_R528); break; -#if FFESTR_F90 - case FFESTR_firstDEALLOCATE: - ffestb_args.heap.len = FFESTR_firstlDEALLOCATE; - ffestb_args.heap.badname = "DEALLOCATE"; - ffestb_args.heap.ctx = FFEEXPR_contextDEALLOCATE; - ffesta_add_possible_exec_ ((ffelexHandler) ffestb_heap); - break; -#endif - -#if FFESTR_VXT - case FFESTR_firstDECODE: - ffestb_args.vxtcode.len = FFESTR_firstlDECODE; - ffestb_args.vxtcode.badname = "DECODE"; - ffesta_add_possible_exec_ ((ffelexHandler) ffestb_vxtcode); - break; -#endif - -#if FFESTR_VXT - case FFESTR_firstDEFINEFILE: - ffesta_add_possible_exec_ ((ffelexHandler) ffestb_V025); - break; - - case FFESTR_firstDELETE: - ffesta_add_possible_exec_ ((ffelexHandler) ffestb_V021); - break; -#endif case FFESTR_firstDIMENSION: ffestb_args.R524.len = FFESTR_firstlDIMENSION; ffestb_args.R524.badname = "DIMENSION"; @@ -752,21 +697,6 @@ ffesta_second_ (ffelexToken t) ffesta_add_possible_exec_ ((ffelexHandler) ffestb_elsexyz); break; -#if FFESTR_F90 - case FFESTR_firstELSEWHERE: - ffestb_args.elsexyz.second = FFESTR_secondWHERE; - ffesta_add_possible_exec_ ((ffelexHandler) ffestb_elsexyz); - break; -#endif - -#if FFESTR_VXT - case FFESTR_firstENCODE: - ffestb_args.vxtcode.len = FFESTR_firstlENCODE; - ffestb_args.vxtcode.badname = "ENCODE"; - ffesta_add_possible_exec_ ((ffelexHandler) ffestb_vxtcode); - break; -#endif - case FFESTR_firstEND: if ((ffelex_token_type (ffesta_token_0_) == FFELEX_typeNAMES) || (ffelex_token_type (t) != FFELEX_typeNAME)) @@ -781,15 +711,9 @@ ffesta_second_ (ffelexToken t) case FFESTR_secondFILE: case FFESTR_secondFUNCTION: case FFESTR_secondIF: -#if FFESTR_F90 - case FFESTR_secondMODULE: -#endif case FFESTR_secondPROGRAM: case FFESTR_secondSELECT: case FFESTR_secondSUBROUTINE: -#if FFESTR_F90 - case FFESTR_secondWHERE: -#endif ffesta_add_possible_exec_ ((ffelexHandler) ffestb_end); break; @@ -836,30 +760,6 @@ ffesta_second_ (ffelexToken t) ffesta_add_possible_exec_ ((ffelexHandler) ffestb_endxyz); break; -#if FFESTR_F90 - case FFESTR_firstENDINTERFACE: - ffestb_args.endxyz.len = FFESTR_firstlENDINTERFACE; - ffestb_args.endxyz.second = FFESTR_secondINTERFACE; - ffesta_add_possible_nonexec_ ((ffelexHandler) ffestb_endxyz); - break; -#endif - -#if FFESTR_VXT - case FFESTR_firstENDMAP: - ffestb_args.endxyz.len = FFESTR_firstlENDMAP; - ffestb_args.endxyz.second = FFESTR_secondMAP; - ffesta_add_possible_nonexec_ ((ffelexHandler) ffestb_endxyz); - break; -#endif - -#if FFESTR_F90 - case FFESTR_firstENDMODULE: - ffestb_args.endxyz.len = FFESTR_firstlENDMODULE; - ffestb_args.endxyz.second = FFESTR_secondMODULE; - ffesta_add_possible_exec_ ((ffelexHandler) ffestb_endxyz); - break; -#endif - case FFESTR_firstENDPROGRAM: ffestb_args.endxyz.len = FFESTR_firstlENDPROGRAM; ffestb_args.endxyz.second = FFESTR_secondPROGRAM; @@ -872,44 +772,12 @@ ffesta_second_ (ffelexToken t) ffesta_add_possible_exec_ ((ffelexHandler) ffestb_endxyz); break; -#if FFESTR_VXT - case FFESTR_firstENDSTRUCTURE: - ffestb_args.endxyz.len = FFESTR_firstlENDSTRUCTURE; - ffestb_args.endxyz.second = FFESTR_secondSTRUCTURE; - ffesta_add_possible_nonexec_ ((ffelexHandler) ffestb_endxyz); - break; -#endif - case FFESTR_firstENDSUBROUTINE: ffestb_args.endxyz.len = FFESTR_firstlENDSUBROUTINE; ffestb_args.endxyz.second = FFESTR_secondSUBROUTINE; ffesta_add_possible_exec_ ((ffelexHandler) ffestb_endxyz); break; -#if FFESTR_F90 - case FFESTR_firstENDTYPE: - ffestb_args.endxyz.len = FFESTR_firstlENDTYPE; - ffestb_args.endxyz.second = FFESTR_secondTYPE; - ffesta_add_possible_nonexec_ ((ffelexHandler) ffestb_endxyz); - break; -#endif - -#if FFESTR_VXT - case FFESTR_firstENDUNION: - ffestb_args.endxyz.len = FFESTR_firstlENDUNION; - ffestb_args.endxyz.second = FFESTR_secondUNION; - ffesta_add_possible_nonexec_ ((ffelexHandler) ffestb_endxyz); - break; -#endif - -#if FFESTR_F90 - case FFESTR_firstENDWHERE: - ffestb_args.endxyz.len = FFESTR_firstlENDWHERE; - ffestb_args.endxyz.second = FFESTR_secondWHERE; - ffesta_add_possible_exec_ ((ffelexHandler) ffestb_endxyz); - break; -#endif - case FFESTR_firstENTRY: ffestb_args.dummy.len = FFESTR_firstlENTRY; ffestb_args.dummy.badname = "ENTRY"; @@ -931,12 +799,6 @@ ffesta_second_ (ffelexToken t) ffesta_add_possible_nonexec_ ((ffelexHandler) ffestb_varlist); break; -#if FFESTR_VXT - case FFESTR_firstFIND: - ffesta_add_possible_exec_ ((ffelexHandler) ffestb_V026); - break; -#endif - /* WARNING: don't put anything that might cause an item to precede FORMAT in the list of possible statements (it's added below) without making sure FORMAT still is first. It has to run with @@ -1008,20 +870,6 @@ ffesta_second_ (ffelexToken t) ffesta_add_possible_nonexec_ ((ffelexHandler) ffestb_decl_gentype); break; -#if FFESTR_F90 - case FFESTR_firstINTENT: - ffestb_args.varlist.len = FFESTR_firstlINTENT; - ffestb_args.varlist.badname = "INTENT"; - ffesta_add_possible_nonexec_ ((ffelexHandler) ffestb_varlist); - break; -#endif - -#if FFESTR_F90 - case FFESTR_firstINTERFACE: - ffesta_add_possible_nonexec_ ((ffelexHandler) ffestb_R1202); - break; -#endif - case FFESTR_firstINTRINSIC: ffestb_args.varlist.len = FFESTR_firstlINTRINSIC; ffestb_args.varlist.badname = "INTRINSIC"; @@ -1034,40 +882,14 @@ ffesta_second_ (ffelexToken t) ffesta_add_possible_nonexec_ ((ffelexHandler) ffestb_decl_gentype); break; -#if FFESTR_VXT - case FFESTR_firstMAP: - ffesta_add_possible_nonexec_ ((ffelexHandler) ffestb_V012); - break; -#endif - -#if FFESTR_F90 - case FFESTR_firstMODULE: - ffesta_add_possible_nonexec_ ((ffelexHandler) ffestb_module); - break; -#endif - case FFESTR_firstNAMELIST: ffesta_add_possible_nonexec_ ((ffelexHandler) ffestb_R542); break; -#if FFESTR_F90 - case FFESTR_firstNULLIFY: - ffesta_add_possible_exec_ ((ffelexHandler) ffestb_R624); - break; -#endif - case FFESTR_firstOPEN: ffesta_add_possible_exec_ ((ffelexHandler) ffestb_R904); break; -#if FFESTR_F90 - case FFESTR_firstOPTIONAL: - ffestb_args.varlist.len = FFESTR_firstlOPTIONAL; - ffestb_args.varlist.badname = "OPTIONAL"; - ffesta_add_possible_nonexec_ ((ffelexHandler) ffestb_varlist); - break; -#endif - case FFESTR_firstPARAMETER: ffesta_add_possible_nonexec_ ((ffelexHandler) ffestb_R537); ffesta_add_possible_nonexec_ ((ffelexHandler) ffestb_V027); @@ -1078,38 +900,14 @@ ffesta_second_ (ffelexToken t) ffesta_add_possible_exec_ ((ffelexHandler) ffestb_halt); break; -#if FFESTR_F90 - case FFESTR_firstPOINTER: - ffestb_args.dimlist.len = FFESTR_firstlPOINTER; - ffestb_args.dimlist.badname = "POINTER"; - ffesta_add_possible_nonexec_ ((ffelexHandler) ffestb_dimlist); - break; -#endif - case FFESTR_firstPRINT: ffesta_add_possible_exec_ ((ffelexHandler) ffestb_R911); break; -#if HARD_F90 - case FFESTR_firstPRIVATE: - ffestb_args.varlist.len = FFESTR_firstlPRIVATE; - ffestb_args.varlist.badname = "ACCESS"; - ffesta_add_possible_nonexec_ ((ffelexHandler) ffestb_varlist); - break; -#endif - case FFESTR_firstPROGRAM: ffesta_add_possible_nonexec_ ((ffelexHandler) ffestb_R1102); break; -#if HARD_F90 - case FFESTR_firstPUBLIC: - ffestb_args.varlist.len = FFESTR_firstlPUBLIC; - ffestb_args.varlist.badname = "ACCESS"; - ffesta_add_possible_nonexec_ ((ffelexHandler) ffestb_varlist); - break; -#endif - case FFESTR_firstREAD: ffesta_add_possible_exec_ ((ffelexHandler) ffestb_R909); break; @@ -1120,18 +918,6 @@ ffesta_second_ (ffelexToken t) ffesta_add_possible_nonexec_ ((ffelexHandler) ffestb_decl_gentype); break; -#if FFESTR_VXT - case FFESTR_firstRECORD: - ffesta_add_possible_nonexec_ ((ffelexHandler) ffestb_V016); - break; -#endif - -#if FFESTR_F90 - case FFESTR_firstRECURSIVE: - ffesta_add_possible_nonexec_ ((ffelexHandler) ffestb_decl_recursive); - break; -#endif - case FFESTR_firstRETURN: ffesta_add_possible_exec_ ((ffelexHandler) ffestb_R1227); break; @@ -1142,12 +928,6 @@ ffesta_second_ (ffelexToken t) ffesta_add_possible_exec_ ((ffelexHandler) ffestb_beru); break; -#if FFESTR_VXT - case FFESTR_firstREWRITE: - ffesta_add_possible_exec_ ((ffelexHandler) ffestb_V018); - break; -#endif - case FFESTR_firstSAVE: ffesta_add_possible_nonexec_ ((ffelexHandler) ffestb_R522); break; @@ -1160,23 +940,11 @@ ffesta_second_ (ffelexToken t) ffesta_add_possible_exec_ ((ffelexHandler) ffestb_R809); break; -#if HARD_F90 - case FFESTR_firstSEQUENCE: - ffesta_add_possible_nonexec_ ((ffelexHandler) ffestb_R423B); - break; -#endif - case FFESTR_firstSTOP: ffestb_args.halt.len = FFESTR_firstlSTOP; ffesta_add_possible_exec_ ((ffelexHandler) ffestb_halt); break; -#if FFESTR_VXT - case FFESTR_firstSTRUCTURE: - ffesta_add_possible_nonexec_ ((ffelexHandler) ffestb_V003); - break; -#endif - case FFESTR_firstSUBROUTINE: ffestb_args.dummy.len = FFESTR_firstlSUBROUTINE; ffestb_args.dummy.badname = "SUBROUTINE"; @@ -1184,50 +952,10 @@ ffesta_second_ (ffelexToken t) ffesta_add_possible_nonexec_ ((ffelexHandler) ffestb_dummy); break; -#if FFESTR_F90 - case FFESTR_firstTARGET: - ffestb_args.dimlist.len = FFESTR_firstlTARGET; - ffestb_args.dimlist.badname = "TARGET"; - ffesta_add_possible_nonexec_ ((ffelexHandler) ffestb_dimlist); - break; -#endif - case FFESTR_firstTYPE: ffesta_add_possible_exec_ ((ffelexHandler) ffestb_V020); break; -#if FFESTR_F90 - case FFESTR_firstTYPE: - ffesta_add_possible_nonexec_ ((ffelexHandler) ffestb_type); - break; -#endif - -#if HARD_F90 - case FFESTR_firstTYPE: - ffesta_add_possible_nonexec_ ((ffelexHandler) ffestb_decl_typetype); - break; -#endif - -#if FFESTR_VXT - case FFESTR_firstUNLOCK: - ffestb_args.beru.len = FFESTR_firstlUNLOCK; - ffestb_args.beru.badname = "UNLOCK"; - ffesta_add_possible_exec_ ((ffelexHandler) ffestb_beru); - break; -#endif - -#if FFESTR_VXT - case FFESTR_firstUNION: - ffesta_add_possible_nonexec_ ((ffelexHandler) ffestb_V009); - break; -#endif - -#if FFESTR_F90 - case FFESTR_firstUSE: - ffesta_add_possible_nonexec_ ((ffelexHandler) ffestb_R1107); - break; -#endif - case FFESTR_firstVIRTUAL: ffestb_args.R524.len = FFESTR_firstlVIRTUAL; ffestb_args.R524.badname = "VIRTUAL"; @@ -1238,12 +966,6 @@ ffesta_second_ (ffelexToken t) ffesta_add_possible_nonexec_ ((ffelexHandler) ffestb_V014); break; -#if HARD_F90 - case FFESTR_firstWHERE: - ffesta_add_possible_exec_ ((ffelexHandler) ffestb_where); - break; -#endif - case FFESTR_firstWORD: ffestb_args.decl.len = FFESTR_firstlWORD; ffestb_args.decl.type = FFESTP_typeWORD; @@ -1290,13 +1012,7 @@ ffesta_second_ (ffelexToken t) ffesta_add_possible_unnamed_exec_ ((ffelexHandler) ffestb_let); break; -#if FFESTR_F90 - case FFELEX_typePERCENT: -#endif case FFELEX_typeEQUALS: -#if FFESTR_F90 - case FFELEX_typePOINTS: -#endif ffesta_add_possible_unnamed_exec_ ((ffelexHandler) ffestb_let); break; diff --git a/gcc/f/stb.c b/gcc/f/stb.c index 57d7ac3..2264a70 100644 --- a/gcc/f/stb.c +++ b/gcc/f/stb.c @@ -1,5 +1,6 @@ /* 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. @@ -216,13 +217,6 @@ union ffestb_local_u_ ffestrOther kw; } varlist; -#if FFESTR_F90 - struct - { - ffestrOther kw; - } - type; -#endif struct { ffelexHandler next; @@ -241,13 +235,6 @@ union ffestb_local_u_ bool complained; /* If run-time expr seen in nonexec context. */ } format; -#if FFESTR_F90 - struct - { - bool started; - } - moduleprocedure; -#endif struct { ffebld expr; @@ -258,47 +245,11 @@ union ffestb_local_u_ 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; @@ -380,13 +331,6 @@ union ffestb_local_u_ ffeexprContext context; } write; -#if FFESTR_F90 - struct - { - bool started; - } - structure; -#endif struct { bool started; @@ -481,10 +425,6 @@ static ffelexHandler ffestb_decl_typeparams_2_ (ffelexToken ft, ffebld expr, 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); @@ -529,26 +469,8 @@ static ffelexHandler ffestb_let1_ (ffelexToken ft, ffebld expr, 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); @@ -599,20 +521,6 @@ static ffelexHandler ffestb_R12271_ (ffelexToken ft, ffebld expr, 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); @@ -645,48 +553,12 @@ static ffelexHandler ffestb_R100117_ (ffelexToken ft, ffebld expr, 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 @@ -717,23 +589,6 @@ static ffelexHandler ffestb_beru7_ (ffelexToken ft, ffebld expr, 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, @@ -814,63 +669,10 @@ static ffelexHandler ffestb_R9239_ (ffelexToken t); 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); @@ -884,30 +686,13 @@ static ffelexHandler ffestb_R5474_ (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); @@ -936,9 +721,6 @@ static ffelexHandler ffestb_decl_entsp_5_ (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); @@ -950,29 +732,12 @@ static ffelexHandler ffestb_decl_funcname_6_ (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); @@ -1737,67 +1502,6 @@ ffestb_decl_typeparams_3_ (ffelexToken ft, ffebld expr, 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 @@ -2664,11 +2368,6 @@ ffestb_elsexyz (ffelexToken t) 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: @@ -2727,16 +2426,6 @@ ffestb_else1_ (ffelexToken t) 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 ()) @@ -2936,20 +2625,6 @@ ffestb_end (ffelexToken t) 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; /* :::::::::::::::::::: */ @@ -3030,19 +2705,6 @@ ffestb_endxyz (ffelexToken t) 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; /* :::::::::::::::::::: */ @@ -3086,24 +2748,6 @@ ffestb_endxyz (ffelexToken t) { 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] @@ -3211,20 +2855,6 @@ ffestb_end3_ (ffelexToken t) 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]); @@ -3245,25 +2875,12 @@ ffestb_end3_ (ffelexToken t) 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]); @@ -3274,27 +2891,6 @@ ffestb_end3_ (ffelexToken t) 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) @@ -3990,29 +3586,29 @@ ffestb_if3_ (ffelexToken t) 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: @@ -4022,88 +3618,90 @@ ffestb_where (ffelexToken t) 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); @@ -4111,735 +3709,621 @@ ffestb_where2_ (ffelexToken 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); @@ -4848,372 +4332,400 @@ ffestb_varlist (ffelexToken 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; @@ -5221,18 +4733,16 @@ ffestb_R423B (ffelexToken t) 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: @@ -5241,309 +4751,406 @@ ffestb_R423B (ffelexToken t) 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; /* :::::::::::::::::::: */ @@ -5553,303 +5160,412 @@ ffestb_R528 (ffelexToken t) 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; @@ -5862,371 +5578,241 @@ ffestb_R537 (ffelexToken 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_); + 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: @@ -6235,11 +5821,13 @@ ffestb_R544 (ffelexToken t) 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. */ @@ -6249,179 +5837,182 @@ ffestb_R544 (ffelexToken t) 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; @@ -6429,7 +6020,7 @@ ffestb_R834 (ffelexToken t) 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)) { @@ -6444,17 +6035,17 @@ ffestb_R834 (ffelexToken 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)) { @@ -6466,7 +6057,7 @@ ffestb_R834 (ffelexToken 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; @@ -6478,34 +6069,62 @@ ffestb_R834 (ffelexToken t) 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)) { @@ -6513,13 +6132,13 @@ ffestb_R8341_ (ffelexToken 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; } @@ -6528,26 +6147,30 @@ ffestb_R8341_ (ffelexToken t) 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. */ @@ -6557,628 +6180,615 @@ ffestb_R835 (ffelexToken t) 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; /* :::::::::::::::::::: */ @@ -7186,9298 +6796,2488 @@ ffestb_R1102 (ffelexToken t) 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 "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 "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: @@ -16485,841 +9285,846 @@ ffestb_R911 (ffelexToken t) } 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)) { @@ -17327,810 +10132,695 @@ ffestb_V0183_ (ffelexToken ft, ffebld expr, ffelexToken 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; @@ -18154,52 +10844,52 @@ ffestb_V021 (ffelexToken t) 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; @@ -18208,27 +10898,168 @@ ffestb_V0212_ (ffelexToken t) { 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)) { @@ -18236,335 +11067,440 @@ ffestb_V0213_ (ffelexToken ft, ffebld expr, ffelexToken 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; @@ -18573,68 +11509,68 @@ ffestb_V0262_ (ffelexToken t) { 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)) { @@ -18642,359 +11578,454 @@ ffestb_V0264_ (ffelexToken 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: @@ -19002,636 +12033,569 @@ ffestb_dimlist (ffelexToken t) } 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_ -- 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: @@ -19641,44 +12605,61 @@ ffestb_R524 (ffelexToken t) 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: @@ -19686,1131 +12667,922 @@ ffestb_R524 (ffelexToken t) } 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: @@ -20824,215 +13596,220 @@ ffestb_decl_double (ffelexToken t) 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_ -- 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; /* :::::::::::::::::::: */ @@ -21040,621 +13817,491 @@ ffestb_decl_recursive (ffelexToken t) 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; /* :::::::::::::::::::: */ @@ -21662,760 +14309,781 @@ ffestb_decl_attrs_2_ (ffelexToken t) 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; @@ -22423,138 +15091,105 @@ ffestb_decl_ents_8_ (ffelexToken ft, ffebld expr, ffelexToken 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_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; @@ -22566,904 +15201,927 @@ ffestb_decl_ents_11_ (ffelexToken t) 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; @@ -23476,27 +16134,38 @@ ffestb_decl_funcname_7_ (ffelexToken t) 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; @@ -23510,649 +16179,633 @@ ffestb_decl_funcname_8_ (ffelexToken t) 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 @@ -24423,12 +17076,6 @@ ffestb_decl_R539 (ffelexToken t) 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; /* :::::::::::::::::::: */ } @@ -24509,12 +17156,6 @@ ffestb_decl_R539 (ffelexToken t) 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; /* :::::::::::::::::::: */ } @@ -24619,34 +17260,6 @@ bad: /* :::::::::::::::::::: */ 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 @@ -24734,12 +17347,6 @@ ffestb_decl_R5395_ (ffelexToken t) 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; } diff --git a/gcc/f/stb.h b/gcc/f/stb.h index a9b3acc..88cb7c5 100644 --- a/gcc/f/stb.h +++ b/gcc/f/stb.h @@ -1,5 +1,5 @@ /* stb.h -- Private #include File (module.h template V1.0) - Copyright (C) 1995, 1996 Free Software Foundation, Inc. + Copyright (C) 1995, 1996, 2003 Free Software Foundation, Inc. Contributed by James Craig Burley. This file is part of GNU Fortran. @@ -79,15 +79,6 @@ struct _ffestb_args_ ffeTokenLength len; /* Length of "STOP/PAUSE". */ } halt; -#if FFESTR_F90 - struct - { - const char *badname; - ffeTokenLength len; /* Length of "ALLOCATE/DEALLOCATE". */ - ffeexprContext ctx; /* Either ALLOCATE or DEALLOCATE. */ - } - heap; -#endif struct { const char *badname; @@ -96,22 +87,6 @@ struct _ffestb_args_ PRIVATE". */ } varlist; -#if FFESTR_VXT - struct - { - const char *badname; - ffeTokenLength len; /* Length of "ENCODE/DECODE". */ - } - vxtcode; -#endif -#if FFESTR_F90 - struct - { - const char *badname; - ffeTokenLength len; /* Length of "ALLOCATABLE/POINTER/TARGET". */ - } - dimlist; -#endif struct { const char *badname; @@ -150,33 +125,9 @@ ffelexHandler ffestb_endxyz (ffelexToken t); ffelexHandler ffestb_decl_gentype (ffelexToken t); ffelexHandler ffestb_goto (ffelexToken t); ffelexHandler ffestb_halt (ffelexToken t); -#if FFESTR_F90 -ffelexHandler ffestb_heap (ffelexToken t); -#endif ffelexHandler ffestb_if (ffelexToken t); ffelexHandler ffestb_let (ffelexToken t); -#if FFESTR_F90 -ffelexHandler ffestb_module (ffelexToken t); -#endif -#if FFESTR_F90 -ffelexHandler ffestb_decl_recursive (ffelexToken t); -#endif -#if FFESTR_F90 -ffelexHandler ffestb_type (ffelexToken t); -#endif -#if FFESTR_F90 -ffelexHandler ffestb_decl_typetype (ffelexToken t); -#endif ffelexHandler ffestb_varlist (ffelexToken t); -#if FFESTR_VXT -ffelexHandler ffestb_vxtcode (ffelexToken t); -#endif -#if FFESTR_F90 -ffelexHandler ffestb_where (ffelexToken t); -#endif -#if HARD_F90 -ffelexHandler ffestb_R423B (ffelexToken t); -#endif ffelexHandler ffestb_R522 (ffelexToken t); ffelexHandler ffestb_R524 (ffelexToken t); ffelexHandler ffestb_R528 (ffelexToken t); @@ -185,9 +136,6 @@ ffelexHandler ffestb_decl_R539 (ffelexToken t); ffelexHandler ffestb_R542 (ffelexToken t); ffelexHandler ffestb_R544 (ffelexToken t); ffelexHandler ffestb_R547 (ffelexToken t); -#if FFESTR_F90 -ffelexHandler ffestb_R624 (ffelexToken t); -#endif ffelexHandler ffestb_R809 (ffelexToken t); ffelexHandler ffestb_R810 (ffelexToken t); ffelexHandler ffestb_R834 (ffelexToken t); @@ -203,36 +151,12 @@ ffelexHandler ffestb_R911 (ffelexToken t); ffelexHandler ffestb_R923 (ffelexToken t); ffelexHandler ffestb_R1001 (ffelexToken t); ffelexHandler ffestb_R1102 (ffelexToken t); -#if FFESTR_F90 -ffelexHandler ffestb_R1107 (ffelexToken t); -#endif -#if FFESTR_F90 -ffelexHandler ffestb_R1202 (ffelexToken t); -#endif ffelexHandler ffestb_R1212 (ffelexToken t); ffelexHandler ffestb_R1227 (ffelexToken t); -#if FFESTR_F90 -ffelexHandler ffestb_R1228 (ffelexToken t); -#endif ffelexHandler ffestb_R1229 (ffelexToken t); ffelexHandler ffestb_S3P4 (ffelexToken t); -#if FFESTR_VXT -ffelexHandler ffestb_V003 (ffelexToken t); -ffelexHandler ffestb_V009 (ffelexToken t); -ffelexHandler ffestb_V012 (ffelexToken t); -#endif ffelexHandler ffestb_V014 (ffelexToken t); -#if FFESTR_VXT -ffelexHandler ffestb_V016 (ffelexToken t); -ffelexHandler ffestb_V018 (ffelexToken t); -ffelexHandler ffestb_V019 (ffelexToken t); -#endif ffelexHandler ffestb_V020 (ffelexToken t); -#if FFESTR_VXT -ffelexHandler ffestb_V021 (ffelexToken t); -ffelexHandler ffestb_V025 (ffelexToken t); -ffelexHandler ffestb_V026 (ffelexToken t); -#endif ffelexHandler ffestb_V027 (ffelexToken t); /* Define macros. */ diff --git a/gcc/f/stc.c b/gcc/f/stc.c index b9602c2..19639c1 100644 --- a/gcc/f/stc.c +++ b/gcc/f/stc.c @@ -170,15 +170,6 @@ union ffestc_local_u_ 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. */ @@ -226,9 +217,6 @@ static bool ffestc_labelref_is_format_ (ffelexToken label_token, 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); @@ -236,17 +224,8 @@ static void ffestc_order_any_ (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); @@ -256,89 +235,26 @@ static ffestcOrder_ ffestc_order_iface_ (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); @@ -377,13 +293,7 @@ static void ffestc_try_shriek_do_ (void); || 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 /* ffestc_establish_declinfo_ -- Determine specific type/params info for entity @@ -1834,58 +1744,6 @@ ffestc_labelref_is_loopend_ (ffelexToken label_token, ffelab *x_label) return TRUE; } -/* ffestc_order_access_ -- Check ordering on 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 statement if (ffestc_order_actiondo_() != FFESTC_orderOK_) @@ -1918,16 +1776,10 @@ ffestc_order_actiondo_ () 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: @@ -1995,16 +1847,10 @@ recurse: 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: @@ -2082,9 +1928,6 @@ recurse: return FFESTC_orderOK_; case FFESTV_stateWHERE: -#if FFESTR_F90 - ffestc_shriek_after1_ = ffestc_shriek_where_; -#endif return FFESTC_orderOK_; case FFESTV_stateIF: @@ -2092,9 +1935,6 @@ recurse: return FFESTC_orderOK_; case FFESTV_stateUSE: -#if FFESTR_F90 - ffestc_shriek_end_uses_ (TRUE); -#endif goto recurse; /* :::::::::::::::::::: */ default: @@ -2170,9 +2010,6 @@ recurse: return; case FFESTV_stateWHERE: -#if FFESTR_F90 - ffestc_shriek_after1_ = ffestc_shriek_where_; -#endif return; case FFESTV_stateIF: @@ -2180,9 +2017,6 @@ recurse: return; case FFESTV_stateUSE: -#if FFESTR_F90 - ffestc_shriek_end_uses_ (TRUE); -#endif goto recurse; /* :::::::::::::::::::: */ default: @@ -2254,16 +2088,10 @@ ffestc_order_blockdata_ () 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: @@ -2336,118 +2164,10 @@ ffestc_order_blockspec_ () 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 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: @@ -2459,21 +2179,7 @@ ffestc_order_contains_ () 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_) @@ -2534,16 +2240,10 @@ ffestc_order_data_ () 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: @@ -2619,16 +2319,10 @@ ffestc_order_data77_ () 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: @@ -2641,65 +2335,21 @@ ffestc_order_data77_ () return FFESTC_orderBAD_; } } +/* ffestc_order_do_ -- Check ordering on 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: @@ -2713,53 +2363,21 @@ ffestc_order_derivedtype_ () } } -#endif -/* ffestc_order_do_ -- Check ordering on 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); @@ -2780,16 +2398,10 @@ ffestc_order_entry_ () 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: @@ -2870,16 +2482,10 @@ recurse: 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: @@ -2958,16 +2564,10 @@ ffestc_order_format_ () 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: @@ -3002,16 +2602,10 @@ ffestc_order_function_ () 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: @@ -3045,9 +2639,6 @@ ffestc_order_iface_ () case FFESTV_stateWHERE: ffestc_order_bad_ (); -#if FFESTR_F90 - ffestc_shriek_where_ (FALSE); -#endif return FFESTC_orderBAD_; case FFESTV_stateIF: @@ -3076,9 +2667,6 @@ ffestc_order_ifthen_ () case FFESTV_stateWHERE: ffestc_order_bad_ (); -#if FFESTR_F90 - ffestc_shriek_where_ (FALSE); -#endif return FFESTC_orderBAD_; case FFESTV_stateIF: @@ -3146,16 +2734,10 @@ ffestc_order_implicit_ () 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: @@ -3216,120 +2798,10 @@ ffestc_order_implicitnone_ () 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 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 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 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: @@ -3343,7 +2815,6 @@ ffestc_order_module_ () } } -#endif /* ffestc_order_parameter_ -- Check ordering on statement if (ffestc_order_parameter_() != FFESTC_orderOK_) @@ -3407,16 +2878,10 @@ ffestc_order_parameter_ () 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: @@ -3455,16 +2920,10 @@ ffestc_order_program_ () 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: @@ -3544,16 +3003,38 @@ ffestc_order_progspec_ () 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 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: @@ -3567,14 +3048,13 @@ ffestc_order_progspec_ () } } -/* 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: @@ -3605,40 +3085,16 @@ ffestc_order_record_ () 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: @@ -3651,27 +3107,31 @@ ffestc_order_record_ () return FFESTC_orderBAD_; } } +/* ffestc_order_subroutine_ -- Check ordering on statement -#endif -/* ffestc_order_selectcase_ -- Check ordering on 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: @@ -3685,13 +3145,13 @@ ffestc_order_selectcase_ () } } -/* ffestc_order_sfunc_ -- Check ordering on statement-function definition +/* ffestc_order_typedecl_ -- Check ordering on statement - if (ffestc_order_sfunc_() != FFESTC_orderOK_) + if (ffestc_order_typedecl_() != FFESTC_orderOK_) return; */ static ffestcOrder_ -ffestc_order_sfunc_ () +ffestc_order_typedecl_ () { recurse: @@ -3722,22 +3182,32 @@ ffestc_order_sfunc_ () 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: @@ -3750,62 +3220,22 @@ ffestc_order_sfunc_ () return FFESTC_orderBAD_; } } +/* ffestc_order_unit_ -- Check ordering on statement -/* ffestc_order_spec_ -- Check ordering on 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_ (); @@ -3817,8940 +3247,6045 @@ ffestc_order_spec_ () 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 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 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 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 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 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 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 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); @@ -12762,8 +9297,9 @@ ffestc_R1229_start (ffelexToken name, ffesttTokenList args, 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; @@ -12772,972 +9308,1007 @@ ffestc_R1229_start (ffelexToken name, ffesttTokenList args, 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_) { @@ -13746,76 +10317,71 @@ ffestc_V025_start () } 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(); diff --git a/gcc/f/stc.h b/gcc/f/stc.h index 8b2f7c3..37feba6 100644 --- a/gcc/f/stc.h +++ b/gcc/f/stc.h @@ -1,5 +1,5 @@ /* stc.h -- Private #include File (module.h template V1.0) - Copyright (C) 1995 Free Software Foundation, Inc. + Copyright (C) 1995, 2003 Free Software Foundation, Inc. Contributed by James Craig Burley. This file is part of GNU Fortran. @@ -77,36 +77,8 @@ void ffestc_init_4 (void); bool ffestc_is_decl_not_R1219 (void); bool ffestc_is_entry_in_subr (void); bool ffestc_is_let_not_V027 (void); -#if FFESTR_F90 -void ffestc_let (ffebld dest, ffebld source, ffelexToken source_token); -#else #define ffestc_let ffestc_R737 -#endif -#if FFESTR_F90 -void ffestc_module (ffelexToken module_name, ffelexToken procedure_name); -#endif -#if FFESTR_F90 -void ffestc_private (void); -#endif void ffestc_terminate_4 (void); -#if FFESTR_F90 -void ffestc_R423A (void); -void ffestc_R423B (void); -void ffestc_R424 (ffelexToken access, ffestrOther access_kw, ffelexToken name); -void ffestc_R425 (ffelexToken name); -void ffestc_R426_start (ffestpType type, ffelexToken typet, ffebld kind, - ffelexToken kindt, ffebld len, ffelexToken lent); -void ffestc_R426_attrib (ffestpAttrib attrib, ffelexToken attribt, - ffestrOther intent_kw, ffesttDimList dims); -void ffestc_R426_item (ffelexToken name, ffebld kind, ffelexToken kindt, - ffesttDimList dims, ffebld len, ffelexToken lent, ffebld init, - ffelexToken initt, bool clist); -void ffestc_R426_itemstartvals (void); -void ffestc_R426_itemvalue (ffebld repeat, ffelexToken repeat_token, - ffebld value, ffelexToken value_token); -void ffestc_R426_itemendvals (ffelexToken t); -void ffestc_R426_finish (void); -#endif void ffestc_R501_start (ffestpType type, ffelexToken typet, ffebld kind, ffelexToken kindt, ffebld len, ffelexToken lent); void ffestc_R501_attrib (ffestpAttrib attrib, ffelexToken attribt, @@ -119,22 +91,6 @@ void ffestc_R501_itemvalue (ffebld repeat, ffelexToken repeat_token, ffebld value, ffelexToken value_token); void ffestc_R501_itemendvals (ffelexToken t); void ffestc_R501_finish (void); -#if FFESTR_F90 -void ffestc_R519_start (ffelexToken intent, ffestrOther intent_kw); -void ffestc_R519_item (ffelexToken name); -void ffestc_R519_finish (void); -void ffestc_R520_start (void); -void ffestc_R520_item (ffelexToken name); -void ffestc_R520_finish (void); -void ffestc_R521A (void); -void ffestc_R521Astart (void); -void ffestc_R521Aitem (ffelexToken name); -void ffestc_R521Afinish (void); -void ffestc_R521B (void); -void ffestc_R521Bstart (void); -void ffestc_R521Bitem (ffelexToken name); -void ffestc_R521Bfinish (void); -#endif void ffestc_R522 (void); void ffestc_R522start (void); void ffestc_R522item_object (ffelexToken name); @@ -143,17 +99,6 @@ void ffestc_R522finish (void); void ffestc_R524_start (bool virtual); void ffestc_R524_item (ffelexToken name, ffesttDimList dims); void ffestc_R524_finish (void); -#if FFESTR_F90 -void ffestc_R525_start (void); -void ffestc_R525_item (ffelexToken name, ffesttDimList dims); -void ffestc_R525_finish (void); -void ffestc_R526_start (void); -void ffestc_R526_item (ffelexToken name, ffesttDimList dims); -void ffestc_R526_finish (void); -void ffestc_R527_start (void); -void ffestc_R527_item (ffelexToken name, ffesttDimList dims); -void ffestc_R527_finish (void); -#endif void ffestc_R528_start (void); void ffestc_R528_item_object (ffebld expr, ffelexToken expr_token); void ffestc_R528_item_startvals (void); @@ -181,21 +126,7 @@ void ffestc_R547_start (void); void ffestc_R547_item_object (ffelexToken name, ffesttDimList dims); void ffestc_R547_item_cblock (ffelexToken name); void ffestc_R547_finish (void); -#if FFESTR_F90 -void ffestc_R620 (ffesttExprList objects, ffebld stat, - ffelexToken stat_token); -void ffestc_R624 (ffesttExprList pointers); -void ffestc_R625 (ffesttExprList objects, ffebld stat, - ffelexToken stat_token); -#endif void ffestc_R737 (ffebld dest, ffebld source, ffelexToken source_token); -#if FFESTR_F90 -void ffestc_R738 (ffebld dest, ffebld source, ffelexToken source_token); -void ffestc_R740 (ffebld expr, ffelexToken expr_token); -void ffestc_R742 (ffebld expr, ffelexToken expr_token); -void ffestc_R744 (void); -void ffestc_R745 (void); -#endif void ffestc_R803 (ffelexToken construct_name, ffebld expr, ffelexToken expr_token); void ffestc_R804 (ffebld expr, ffelexToken expr_token, ffelexToken name); @@ -251,22 +182,8 @@ void ffestc_R923B_finish (void); void ffestc_R1001 (ffesttFormatList f); void ffestc_R1102 (ffelexToken name); void ffestc_R1103 (ffelexToken name); -#if FFESTR_F90 -void ffestc_R1105 (ffelexToken name); -void ffestc_R1106 (ffelexToken name); -void ffestc_R1107_start (ffelexToken name, bool only); -void ffestc_R1107_item (ffelexToken local, ffelexToken use); -void ffestc_R1107_finish (void); -#endif void ffestc_R1111 (ffelexToken name); void ffestc_R1112 (ffelexToken name); -#if FFESTR_F90 -void ffestc_R1202 (ffestpDefinedOperator operator, ffelexToken name); -void ffestc_R1203 (void); -void ffestc_R1205_start (void); -void ffestc_R1205_item (ffelexToken name); -void ffestc_R1205_finish (void); -#endif void ffestc_R1207_start (void); void ffestc_R1207_item (ffelexToken name); void ffestc_R1207_finish (void); @@ -274,9 +191,6 @@ void ffestc_R1208_start (void); void ffestc_R1208_item (ffelexToken name); void ffestc_R1208_finish (void); void ffestc_R1212 (ffebld expr, ffelexToken expr_token); -#if FFESTR_F90 -void ffestc_R1213 (ffebld dest, ffebld source, ffelexToken source_token); -#endif void ffestc_R1219 (ffelexToken funcname, ffesttTokenList args, ffelexToken final, ffestpType type, ffebld kind, ffelexToken kindt, ffebld len, ffelexToken lent, ffelexToken recursive, ffelexToken result); @@ -287,57 +201,17 @@ void ffestc_R1225 (ffelexToken name); void ffestc_R1226 (ffelexToken entryname, ffesttTokenList args, ffelexToken final); void ffestc_R1227 (ffebld expr, ffelexToken expr_token); -#if FFESTR_F90 -void ffestc_R1228 (void); -#endif void ffestc_R1229_start (ffelexToken name, ffesttTokenList args, ffelexToken final); void ffestc_R1229_finish (ffebld expr, ffelexToken expr_token); void ffestc_S3P4 (ffebld filename, ffelexToken filename_token); -#if FFESTR_VXT -void ffestc_V003_start (ffelexToken structure_name); -void ffestc_V003_item (ffelexToken name, ffesttDimList dims); -void ffestc_V003_finish (void); -void ffestc_V004 (void); -void ffestc_V009 (void); -void ffestc_V010 (void); -void ffestc_V012 (void); -void ffestc_V013 (void); -#endif void ffestc_V014_start (void); void ffestc_V014_item_object (ffelexToken name); void ffestc_V014_item_cblock (ffelexToken name); void ffestc_V014_finish (void); -#if FFESTR_VXT -void ffestc_V016_start (void); -void ffestc_V016_item_structure (ffelexToken name); -void ffestc_V016_item_object (ffelexToken name, ffesttDimList dims); -void ffestc_V016_finish (void); -void ffestc_V018_start (void); -void ffestc_V018_item (ffebld expr, ffelexToken expr_token); -void ffestc_V018_finish (void); -void ffestc_V019_start (void); -void ffestc_V019_item (ffebld expr, ffelexToken expr_token); -void ffestc_V019_finish (void); -#endif void ffestc_V020_start (void); void ffestc_V020_item (ffebld expr, ffelexToken expr_token); void ffestc_V020_finish (void); -#if FFESTR_VXT -void ffestc_V021 (void); -void ffestc_V022 (void); -void ffestc_V023_start (void); -void ffestc_V023_item (ffebld expr, ffelexToken expr_token); -void ffestc_V023_finish (void); -void ffestc_V024_start (void); -void ffestc_V024_item (ffebld expr, ffelexToken expr_token); -void ffestc_V024_finish (void); -void ffestc_V025_start (void); -void ffestc_V025_item (ffebld u, ffelexToken ut, ffebld m, ffelexToken mt, - ffebld n, ffelexToken nt, ffebld asv, ffelexToken asvt); -void ffestc_V025_finish (void); -void ffestc_V026 (void); -#endif void ffestc_V027_start (void); void ffestc_V027_item (ffelexToken dest_token, ffebld source, ffelexToken source_token); diff --git a/gcc/f/std.c b/gcc/f/std.c index 27b5bfe..d225d1c9 100644 --- a/gcc/f/std.c +++ b/gcc/f/std.c @@ -115,21 +115,7 @@ typedef enum FFESTD_stmtidR1225_, /* END_SUBROUTINE */ FFESTD_stmtidR1226_, /* ENTRY */ FFESTD_stmtidR1227_, /* RETURN */ -#if FFESTR_VXT - FFESTD_stmtidV018_, /* REWRITE */ - FFESTD_stmtidV019_, /* ACCEPT */ -#endif FFESTD_stmtidV020_, /* TYPE */ -#if FFESTR_VXT - FFESTD_stmtidV021_, /* DELETE */ - FFESTD_stmtidV022_, /* UNLOCK */ - FFESTD_stmtidV023_, /* ENCODE */ - FFESTD_stmtidV024_, /* DECODE */ - FFESTD_stmtidV025start_, /* DEFINEFILE (start) */ - FFESTD_stmtidV025item_, /* (DEFINEFILE item) */ - FFESTD_stmtidV025finish_, /* (DEFINEFILE finish) */ - FFESTD_stmtidV026_, /* FIND */ -#endif FFESTD_stmtid_, } ffestdStmtId_; @@ -407,24 +393,6 @@ struct _ffestd_stmt_ ffebld expr; } R1227; -#if FFESTR_VXT - struct - { - mallocPool pool; - ffestpRewriteStmt *params; - ffestvFormat format; - ffestdExprItem_ list; - } - V018; - struct - { - mallocPool pool; - ffestpAcceptStmt *params; - ffestvFormat format; - ffestdExprItem_ list; - } - V019; -#endif struct { mallocPool pool; @@ -433,52 +401,6 @@ struct _ffestd_stmt_ ffestdExprItem_ list; } V020; -#if FFESTR_VXT - struct - { - mallocPool pool; - ffestpDeleteStmt *params; - } - V021; - struct - { - mallocPool pool; - ffestpBeruStmt *params; - } - V022; - struct - { - mallocPool pool; - ffestpVxtcodeStmt *params; - ffestdExprItem_ list; - } - V023; - struct - { - mallocPool pool; - ffestpVxtcodeStmt *params; - ffestdExprItem_ list; - } - V024; - struct - { - ffebld u; - ffebld m; - ffebld n; - ffebld asv; - } - V025item; - struct - { - mallocPool pool; - } V025finish; - struct - { - mallocPool pool; - ffestpFindStmt *params; - } - V026; -#endif } u; }; @@ -513,9 +435,6 @@ static void ffestd_stmt_pass_ (void); static ffestpInquireStmt *ffestd_subr_copy_easy_ (ffestpInquireIx max); #endif static void ffestd_subr_vxt_ (void); -#if FFESTR_F90 -static void ffestd_subr_f90_ (void); -#endif static void ffestd_subr_labels_ (bool unexpected); static void ffestd_R1001dump_ (ffests s, ffesttFormatList list); static void ffestd_R1001dump_1005_1_ (ffests s, ffesttFormatList f, @@ -1026,36 +945,6 @@ ffestd_stmt_pass_ () malloc_pool_kill (stmt->u.R1227.pool); break; -#if FFESTR_VXT - case FFESTD_stmtidV018_: - ffestd_subr_line_restore_ (stmt); - if (okay) - ffeste_V018_start (stmt->u.V018.params, stmt->u.V018.format); - for (expr = stmt->u.V018.list; expr != NULL; expr = expr->next) - { - if (okay) - ffeste_V018_item (expr->expr); - } - if (okay) - ffeste_V018_finish (); - malloc_pool_kill (stmt->u.V018.pool); - break; - - case FFESTD_stmtidV019_: - ffestd_subr_line_restore_ (stmt); - if (okay) - ffeste_V019_start (stmt->u.V019.params, stmt->u.V019.format); - for (expr = stmt->u.V019.list; expr != NULL; expr = expr->next) - { - if (okay) - ffeste_V019_item (expr->expr); - } - if (okay) - ffeste_V019_finish (); - malloc_pool_kill (stmt->u.V019.pool); - break; -#endif - case FFESTD_stmtidV020_: ffestd_subr_line_restore_ (stmt); if (okay) @@ -1070,68 +959,6 @@ ffestd_stmt_pass_ () malloc_pool_kill (stmt->u.V020.pool); break; -#if FFESTR_VXT - case FFESTD_stmtidV021_: - ffestd_subr_line_restore_ (stmt); - if (okay) - ffeste_V021 (stmt->u.V021.params); - malloc_pool_kill (stmt->u.V021.pool); - break; - - case FFESTD_stmtidV023_: - ffestd_subr_line_restore_ (stmt); - if (okay) - ffeste_V023_start (stmt->u.V023.params); - for (expr = stmt->u.V023.list; expr != NULL; expr = expr->next) - { - if (okay) - ffeste_V023_item (expr->expr); - } - if (okay) - ffeste_V023_finish (); - malloc_pool_kill (stmt->u.V023.pool); - break; - - case FFESTD_stmtidV024_: - ffestd_subr_line_restore_ (stmt); - if (okay) - ffeste_V024_start (stmt->u.V024.params); - for (expr = stmt->u.V024.list; expr != NULL; expr = expr->next) - { - if (okay) - ffeste_V024_item (expr->expr); - } - if (okay) - ffeste_V024_finish (); - malloc_pool_kill (stmt->u.V024.pool); - break; - - case FFESTD_stmtidV025start_: - ffestd_subr_line_restore_ (stmt); - if (okay) - ffeste_V025_start (); - break; - - case FFESTD_stmtidV025item_: - if (okay) - ffeste_V025_item (stmt->u.V025item.u, stmt->u.V025item.m, - stmt->u.V025item.n, stmt->u.V025item.asv); - break; - - case FFESTD_stmtidV025finish_: - if (okay) - ffeste_V025_finish (); - malloc_pool_kill (stmt->u.V025finish.pool); - break; - - case FFESTD_stmtidV026_: - ffestd_subr_line_restore_ (stmt); - if (okay) - ffeste_V026 (stmt->u.V026.params); - malloc_pool_kill (stmt->u.V026.pool); - break; -#endif - default: assert ("bad stmt->id" == NULL); break; @@ -1270,21 +1097,6 @@ ffestd_subr_labels_ (bool unexpected) assert (undef == 0); } -/* ffestd_subr_f90_ -- Report error about lack of full F90 support - - ffestd_subr_f90_(); */ - -#if FFESTR_F90 -static void -ffestd_subr_f90_ () -{ - ffebad_start (FFEBAD_F90); - ffebad_here (0, ffelex_token_where_line (ffesta_tokens[0]), - ffelex_token_where_column (ffesta_tokens[0])); - ffebad_finish (); -} - -#endif /* ffestd_subr_vxt_ -- Report error about lack of full VXT support ffestd_subr_vxt_(); */ @@ -1337,30 +1149,6 @@ ffestd_do (bool ok UNUSED) assert (ffestd_block_level_ >= 0); } -/* ffestd_end_uses -- End a bunch of USE statements - - ffestd_end_uses(TRUE); - - ok==TRUE means simply not popping due to ffestd_eof_() - being called, because there is no formal END USES statement in Fortran. */ - -#if FFESTR_F90 -void -ffestd_end_uses (bool ok) -{ -} - -/* ffestd_end_R740 -- End a WHERE(-THEN) - - ffestd_end_R740(TRUE); */ - -void -ffestd_end_R740 (bool ok) -{ - return; /* F90. */ -} - -#endif /* ffestd_end_R807 -- End of statement following logical IF ffestd_end_R807(TRUE); @@ -1517,3699 +1305,2275 @@ ffestd_labeldef_useless (ffelab label UNUSED) { } -/* ffestd_R423A -- PRIVATE statement (in R422 derived-type statement) +/* ffestd_R522 -- SAVE statement with no list + + ffestd_R522(); - ffestd_R423A(); */ + Verify that SAVE is valid here, and flag everything as SAVEd. */ -#if FFESTR_F90 void -ffestd_R423A () +ffestd_R522 () { ffestd_check_simple_ (); } -/* ffestd_R423B -- SEQUENCE statement (in R422 derived-type-stmt) +/* ffestd_R522start -- SAVE statement list begin + + ffestd_R522start(); - ffestd_R423B(); */ + Verify that SAVE is valid here, and begin accepting items in the list. */ void -ffestd_R423B () +ffestd_R522start () { - ffestd_check_simple_ (); + ffestd_check_start_ (); } -/* ffestd_R424 -- derived-TYPE-def statement +/* ffestd_R522item_object -- SAVE statement for object-name - ffestd_R424(access_token,access_kw,name_token); + ffestd_R522item_object(name_token); - Handle a derived-type definition. */ + Make sure name_token identifies a valid object to be SAVEd. */ void -ffestd_R424 (ffelexToken access, ffestrOther access_kw, ffelexToken name) +ffestd_R522item_object (ffelexToken name UNUSED) { - ffestd_check_simple_ (); - - ffestd_subr_f90_ (); - return; + ffestd_check_item_ (); +} -#ifdef FFESTD_F90 - char *a; +/* ffestd_R522item_cblock -- SAVE statement for common-block-name - if (access == NULL) - fprintf (dmpout, "* TYPE %s\n", ffelex_token_text (name)); - else - { - switch (access_kw) - { - case FFESTR_otherPUBLIC: - a = "PUBLIC"; - break; + ffestd_R522item_cblock(name_token); - case FFESTR_otherPRIVATE: - a = "PRIVATE"; - break; + Make sure name_token identifies a valid common block to be SAVEd. */ - default: - assert (FALSE); - } - fprintf (dmpout, "* TYPE,%s: %s\n", a, ffelex_token_text (name)); - } -#endif +void +ffestd_R522item_cblock (ffelexToken name UNUSED) +{ + ffestd_check_item_ (); } -/* ffestd_R425 -- End a TYPE +/* ffestd_R522finish -- SAVE statement list complete + + ffestd_R522finish(); - ffestd_R425(TRUE); */ + Just wrap up any local activities. */ void -ffestd_R425 (bool ok) +ffestd_R522finish () { + ffestd_check_finish_ (); } -/* ffestd_R519_start -- INTENT statement list begin +/* ffestd_R524_start -- DIMENSION statement list begin - ffestd_R519_start(); + ffestd_R524_start(bool virtual); - Verify that INTENT is valid here, and begin accepting items in the list. */ + Verify that DIMENSION is valid here, and begin accepting items in the list. */ void -ffestd_R519_start (ffestrOther intent_kw) +ffestd_R524_start (bool virtual UNUSED) { ffestd_check_start_ (); - - ffestd_subr_f90_ (); - return; - -#ifdef FFESTD_F90 - char *a; - - switch (intent_kw) - { - case FFESTR_otherIN: - a = "IN"; - break; - - case FFESTR_otherOUT: - a = "OUT"; - break; - - case FFESTR_otherINOUT: - a = "INOUT"; - break; - - default: - assert (FALSE); - } - fprintf (dmpout, "* INTENT (%s) ", a); -#endif } -/* ffestd_R519_item -- INTENT statement for name +/* ffestd_R524_item -- DIMENSION statement for object-name - ffestd_R519_item(name_token); + ffestd_R524_item(name_token,dim_list); - Make sure name_token identifies a valid object to be INTENTed. */ + Make sure name_token identifies a valid object to be DIMENSIONd. */ void -ffestd_R519_item (ffelexToken name) +ffestd_R524_item (ffelexToken name UNUSED, ffesttDimList dims UNUSED) { ffestd_check_item_ (); - - return; /* F90. */ - -#ifdef FFESTD_F90 - fprintf (dmpout, "%s,", ffelex_token_text (name)); -#endif } -/* ffestd_R519_finish -- INTENT statement list complete +/* ffestd_R524_finish -- DIMENSION statement list complete - ffestd_R519_finish(); + ffestd_R524_finish(); Just wrap up any local activities. */ void -ffestd_R519_finish () +ffestd_R524_finish () { ffestd_check_finish_ (); - - return; /* F90. */ - -#ifdef FFESTD_F90 - fputc ('\n', dmpout); -#endif } -/* ffestd_R520_start -- OPTIONAL statement list begin +/* ffestd_R537_start -- PARAMETER statement list begin - ffestd_R520_start(); + ffestd_R537_start(); - Verify that OPTIONAL is valid here, and begin accepting items in the list. */ + Verify that PARAMETER is valid here, and begin accepting items in the list. */ void -ffestd_R520_start () +ffestd_R537_start () { ffestd_check_start_ (); - - ffestd_subr_f90_ (); - return; - -#ifdef FFESTD_F90 - fputs ("* OPTIONAL ", dmpout); -#endif } -/* ffestd_R520_item -- OPTIONAL statement for name +/* ffestd_R537_item -- PARAMETER statement assignment - ffestd_R520_item(name_token); + ffestd_R537_item(dest,dest_token,source,source_token); - Make sure name_token identifies a valid object to be OPTIONALed. */ + Make sure the source is a valid source for the destination; make the + assignment. */ void -ffestd_R520_item (ffelexToken name) +ffestd_R537_item (ffebld dest UNUSED, ffebld source UNUSED) { ffestd_check_item_ (); - - return; /* F90. */ - -#ifdef FFESTD_F90 - fprintf (dmpout, "%s,", ffelex_token_text (name)); -#endif } -/* ffestd_R520_finish -- OPTIONAL statement list complete +/* ffestd_R537_finish -- PARAMETER statement list complete - ffestd_R520_finish(); + ffestd_R537_finish(); Just wrap up any local activities. */ void -ffestd_R520_finish () +ffestd_R537_finish () { ffestd_check_finish_ (); - - return; /* F90. */ - -#ifdef FFESTD_F90 - fputc ('\n', dmpout); -#endif } -/* ffestd_R521A -- PUBLIC statement +/* ffestd_R539 -- IMPLICIT NONE statement - ffestd_R521A(); + ffestd_R539(); - Verify that PUBLIC is valid here. */ + Verify that the IMPLICIT NONE statement is ok here and implement. */ void -ffestd_R521A () +ffestd_R539 () { ffestd_check_simple_ (); - - ffestd_subr_f90_ (); - return; - -#ifdef FFESTD_F90 - fputs ("* PUBLIC\n", dmpout); -#endif } -/* ffestd_R521Astart -- PUBLIC statement list begin +/* ffestd_R539start -- IMPLICIT statement - ffestd_R521Astart(); + ffestd_R539start(); - Verify that PUBLIC is valid here, and begin accepting items in the list. */ + Verify that the IMPLICIT statement is ok here and implement. */ void -ffestd_R521Astart () +ffestd_R539start () { ffestd_check_start_ (); - - ffestd_subr_f90_ (); - return; - -#ifdef FFESTD_F90 - fputs ("* PUBLIC ", dmpout); -#endif } -/* ffestd_R521Aitem -- PUBLIC statement for name +/* ffestd_R539item -- IMPLICIT statement specification (R540) - ffestd_R521Aitem(name_token); + ffestd_R539item(...); - Make sure name_token identifies a valid object to be PUBLICed. */ + Verify that the type and letter list are all ok and implement. */ void -ffestd_R521Aitem (ffelexToken name) +ffestd_R539item (ffestpType type UNUSED, ffebld kind UNUSED, + ffelexToken kindt UNUSED, ffebld len UNUSED, + ffelexToken lent UNUSED, ffesttImpList letters UNUSED) { ffestd_check_item_ (); - - return; /* F90. */ - -#ifdef FFESTD_F90 - fprintf (dmpout, "%s,", ffelex_token_text (name)); -#endif } -/* ffestd_R521Afinish -- PUBLIC statement list complete +/* ffestd_R539finish -- IMPLICIT statement - ffestd_R521Afinish(); + ffestd_R539finish(); - Just wrap up any local activities. */ + Finish up any local activities. */ void -ffestd_R521Afinish () +ffestd_R539finish () { ffestd_check_finish_ (); - - return; /* F90. */ - -#ifdef FFESTD_F90 - fputc ('\n', dmpout); -#endif } -/* ffestd_R521B -- PRIVATE statement +/* ffestd_R542_start -- NAMELIST statement list begin - ffestd_R521B(); + ffestd_R542_start(); - Verify that PRIVATE is valid here (outside a derived-type statement). */ + Verify that NAMELIST is valid here, and begin accepting items in the list. */ void -ffestd_R521B () +ffestd_R542_start () { - ffestd_check_simple_ (); - - ffestd_subr_f90_ (); - return; - -#ifdef FFESTD_F90 - fputs ("* PRIVATE_outside_of_R422_derived_type_def\n", dmpout); -#endif + ffestd_check_start_ (); } -/* ffestd_R521Bstart -- PRIVATE statement list begin +/* ffestd_R542_item_nlist -- NAMELIST statement for group-name - ffestd_R521Bstart(); + ffestd_R542_item_nlist(groupname_token); - Verify that PRIVATE is valid here, and begin accepting items in the list. */ + Make sure name_token identifies a valid object to be NAMELISTd. */ void -ffestd_R521Bstart () +ffestd_R542_item_nlist (ffelexToken name UNUSED) { - ffestd_check_start_ (); - - ffestd_subr_f90_ (); - return; - -#ifdef FFESTD_F90 - fputs ("* PRIVATE ", dmpout); -#endif + ffestd_check_item_ (); } -/* ffestd_R521Bitem -- PRIVATE statement for name +/* ffestd_R542_item_nitem -- NAMELIST statement for variable-name - ffestd_R521Bitem(name_token); + ffestd_R542_item_nitem(name_token); - Make sure name_token identifies a valid object to be PRIVATEed. */ + Make sure name_token identifies a valid object to be NAMELISTd. */ void -ffestd_R521Bitem (ffelexToken name) +ffestd_R542_item_nitem (ffelexToken name UNUSED) { ffestd_check_item_ (); - - return; /* F90. */ - -#ifdef FFESTD_F90 - fprintf (dmpout, "%s,", ffelex_token_text (name)); -#endif } -/* ffestd_R521Bfinish -- PRIVATE statement list complete +/* ffestd_R542_finish -- NAMELIST statement list complete - ffestd_R521Bfinish(); + ffestd_R542_finish(); Just wrap up any local activities. */ void -ffestd_R521Bfinish () +ffestd_R542_finish () { ffestd_check_finish_ (); - - return; /* F90. */ - -#ifdef FFESTD_F90 - fputc ('\n', dmpout); -#endif -} - -#endif -/* ffestd_R522 -- SAVE statement with no list - - ffestd_R522(); - - Verify that SAVE is valid here, and flag everything as SAVEd. */ - -void -ffestd_R522 () -{ - ffestd_check_simple_ (); } -/* ffestd_R522start -- SAVE statement list begin +/* ffestd_R547_start -- COMMON statement list begin - ffestd_R522start(); + ffestd_R547_start(); - Verify that SAVE is valid here, and begin accepting items in the list. */ + Verify that COMMON is valid here, and begin accepting items in the list. */ void -ffestd_R522start () +ffestd_R547_start () { ffestd_check_start_ (); } -/* ffestd_R522item_object -- SAVE statement for object-name +/* ffestd_R547_item_object -- COMMON statement for object-name - ffestd_R522item_object(name_token); + ffestd_R547_item_object(name_token,dim_list); - Make sure name_token identifies a valid object to be SAVEd. */ + Make sure name_token identifies a valid object to be COMMONd. */ void -ffestd_R522item_object (ffelexToken name UNUSED) +ffestd_R547_item_object (ffelexToken name UNUSED, + ffesttDimList dims UNUSED) { ffestd_check_item_ (); } -/* ffestd_R522item_cblock -- SAVE statement for common-block-name +/* ffestd_R547_item_cblock -- COMMON statement for common-block-name - ffestd_R522item_cblock(name_token); + ffestd_R547_item_cblock(name_token); - Make sure name_token identifies a valid common block to be SAVEd. */ + Make sure name_token identifies a valid common block to be COMMONd. */ void -ffestd_R522item_cblock (ffelexToken name UNUSED) +ffestd_R547_item_cblock (ffelexToken name UNUSED) { ffestd_check_item_ (); } -/* ffestd_R522finish -- SAVE statement list complete +/* ffestd_R547_finish -- COMMON statement list complete - ffestd_R522finish(); + ffestd_R547_finish(); Just wrap up any local activities. */ void -ffestd_R522finish () +ffestd_R547_finish () { ffestd_check_finish_ (); } -/* ffestd_R524_start -- DIMENSION statement list begin - - ffestd_R524_start(bool virtual); +/* ffestd_R737A -- Assignment statement outside of WHERE - Verify that DIMENSION is valid here, and begin accepting items in the list. */ + ffestd_R737A(dest_expr,source_expr); */ void -ffestd_R524_start (bool virtual UNUSED) +ffestd_R737A (ffebld dest, ffebld source) { - ffestd_check_start_ (); -} + ffestdStmt_ stmt; -/* ffestd_R524_item -- DIMENSION statement for object-name + ffestd_check_simple_ (); - ffestd_R524_item(name_token,dim_list); + stmt = ffestd_stmt_new_ (FFESTD_stmtidR737A_); + ffestd_stmt_append_ (stmt); + ffestd_subr_line_save_ (stmt); + stmt->u.R737A.pool = ffesta_output_pool; + stmt->u.R737A.dest = dest; + stmt->u.R737A.source = source; + ffesta_set_outpooldisp (FFESTA_pooldispPRESERVE); +} - Make sure name_token identifies a valid object to be DIMENSIONd. */ + +/* Block IF (IF-THEN) statement. */ void -ffestd_R524_item (ffelexToken name UNUSED, ffesttDimList dims UNUSED) +ffestd_R803 (ffelexToken construct_name UNUSED, ffebld expr) { - ffestd_check_item_ (); -} + ffestdStmt_ stmt; -/* ffestd_R524_finish -- DIMENSION statement list complete + ffestd_check_simple_ (); - ffestd_R524_finish(); + stmt = ffestd_stmt_new_ (FFESTD_stmtidR803_); + ffestd_stmt_append_ (stmt); + ffestd_subr_line_save_ (stmt); + stmt->u.R803.pool = ffesta_output_pool; + stmt->u.R803.block = ffestw_use (ffestw_stack_top ()); + stmt->u.R803.expr = expr; + ffesta_set_outpooldisp (FFESTA_pooldispPRESERVE); - Just wrap up any local activities. */ + ++ffestd_block_level_; + assert (ffestd_block_level_ > 0); +} + +/* ELSE IF statement. */ void -ffestd_R524_finish () +ffestd_R804 (ffebld expr, ffelexToken name UNUSED) { - ffestd_check_finish_ (); -} + ffestdStmt_ stmt; -/* ffestd_R525_start -- ALLOCATABLE statement list begin + ffestd_check_simple_ (); - ffestd_R525_start(); + stmt = ffestd_stmt_new_ (FFESTD_stmtidR804_); + ffestd_stmt_append_ (stmt); + ffestd_subr_line_save_ (stmt); + stmt->u.R804.pool = ffesta_output_pool; + stmt->u.R804.block = ffestw_use (ffestw_stack_top ()); + stmt->u.R804.expr = expr; + ffesta_set_outpooldisp (FFESTA_pooldispPRESERVE); +} - Verify that ALLOCATABLE is valid here, and begin accepting items in the - list. */ +/* ELSE statement. */ -#if FFESTR_F90 void -ffestd_R525_start () +ffestd_R805 (ffelexToken name UNUSED) { - ffestd_check_start_ (); + ffestdStmt_ stmt; - ffestd_subr_f90_ (); - return; + ffestd_check_simple_ (); -#ifdef FFESTD_F90 - fputs ("* ALLOCATABLE ", dmpout); -#endif + stmt = ffestd_stmt_new_ (FFESTD_stmtidR805_); + ffestd_stmt_append_ (stmt); + ffestd_subr_line_save_ (stmt); + stmt->u.R805.block = ffestw_use (ffestw_stack_top ()); } -/* ffestd_R525_item -- ALLOCATABLE statement for object-name - - ffestd_R525_item(name_token,dim_list); - - Make sure name_token identifies a valid object to be ALLOCATABLEd. */ +/* END IF statement. */ void -ffestd_R525_item (ffelexToken name, ffesttDimList dims) +ffestd_R806 (bool ok UNUSED) { - ffestd_check_item_ (); + ffestdStmt_ stmt; - return; /* F90. */ + stmt = ffestd_stmt_new_ (FFESTD_stmtidR806_); + ffestd_stmt_append_ (stmt); + ffestd_subr_line_save_ (stmt); + stmt->u.R806.block = ffestw_use (ffestw_stack_top ()); -#ifdef FFESTD_F90 - fputs (ffelex_token_text (name), dmpout); - if (dims != NULL) - { - fputc ('(', dmpout); - ffestt_dimlist_dump (dims); - fputc (')', dmpout); - } - fputc (',', dmpout); -#endif + --ffestd_block_level_; + assert (ffestd_block_level_ >= 0); } -/* ffestd_R525_finish -- ALLOCATABLE statement list complete +/* ffestd_R807 -- Logical IF statement - ffestd_R525_finish(); + ffestd_R807(expr,expr_token); - Just wrap up any local activities. */ + Make sure statement is valid here; implement. */ void -ffestd_R525_finish () +ffestd_R807 (ffebld expr) { - ffestd_check_finish_ (); + ffestdStmt_ stmt; - return; /* F90. */ + ffestd_check_simple_ (); -#ifdef FFESTD_F90 - fputc ('\n', dmpout); -#endif + stmt = ffestd_stmt_new_ (FFESTD_stmtidR807_); + ffestd_stmt_append_ (stmt); + ffestd_subr_line_save_ (stmt); + stmt->u.R807.pool = ffesta_output_pool; + stmt->u.R807.expr = expr; + ffesta_set_outpooldisp (FFESTA_pooldispPRESERVE); + + ++ffestd_block_level_; + assert (ffestd_block_level_ > 0); } -/* ffestd_R526_start -- POINTER statement list begin +/* ffestd_R809 -- SELECT CASE statement - ffestd_R526_start(); + ffestd_R809(construct_name,expr,expr_token); - Verify that POINTER is valid here, and begin accepting items in the - list. */ + Make sure statement is valid here; implement. */ void -ffestd_R526_start () +ffestd_R809 (ffelexToken construct_name UNUSED, ffebld expr) { - ffestd_check_start_ (); + ffestdStmt_ stmt; - ffestd_subr_f90_ (); - return; + ffestd_check_simple_ (); -#ifdef FFESTD_F90 - fputs ("* POINTER ", dmpout); -#endif + stmt = ffestd_stmt_new_ (FFESTD_stmtidR809_); + ffestd_stmt_append_ (stmt); + ffestd_subr_line_save_ (stmt); + stmt->u.R809.pool = ffesta_output_pool; + stmt->u.R809.block = ffestw_use (ffestw_stack_top ()); + stmt->u.R809.expr = expr; + ffesta_set_outpooldisp (FFESTA_pooldispPRESERVE); + malloc_pool_use (ffestw_select (ffestw_stack_top ())->pool); + + ++ffestd_block_level_; + assert (ffestd_block_level_ > 0); } -/* ffestd_R526_item -- POINTER statement for object-name +/* ffestd_R810 -- CASE statement - ffestd_R526_item(name_token,dim_list); + ffestd_R810(case_value_range_list,name); - Make sure name_token identifies a valid object to be POINTERd. */ + If casenum is 0, it's CASE DEFAULT. Else it's the case ranges at + the start of the first_stmt list in the select object at the top of + the stack that match casenum. */ void -ffestd_R526_item (ffelexToken name, ffesttDimList dims) +ffestd_R810 (unsigned long casenum) { - ffestd_check_item_ (); + ffestdStmt_ stmt; - return; /* F90. */ + ffestd_check_simple_ (); -#ifdef FFESTD_F90 - fputs (ffelex_token_text (name), dmpout); - if (dims != NULL) - { - fputc ('(', dmpout); - ffestt_dimlist_dump (dims); - fputc (')', dmpout); - } - fputc (',', dmpout); -#endif + stmt = ffestd_stmt_new_ (FFESTD_stmtidR810_); + ffestd_stmt_append_ (stmt); + ffestd_subr_line_save_ (stmt); + stmt->u.R810.pool = ffesta_output_pool; + stmt->u.R810.block = ffestw_stack_top (); + stmt->u.R810.casenum = casenum; + ffesta_set_outpooldisp (FFESTA_pooldispPRESERVE); } -/* ffestd_R526_finish -- POINTER statement list complete - - ffestd_R526_finish(); +/* ffestd_R811 -- End a SELECT - Just wrap up any local activities. */ + ffestd_R811(TRUE); */ void -ffestd_R526_finish () +ffestd_R811 (bool ok UNUSED) { - ffestd_check_finish_ (); + ffestdStmt_ stmt; - return; /* F90. */ + stmt = ffestd_stmt_new_ (FFESTD_stmtidR811_); + ffestd_stmt_append_ (stmt); + ffestd_subr_line_save_ (stmt); + stmt->u.R811.block = ffestw_stack_top (); -#ifdef FFESTD_F90 - fputc ('\n', dmpout); -#endif + --ffestd_block_level_; + assert (ffestd_block_level_ >= 0); } -/* ffestd_R527_start -- TARGET statement list begin +/* ffestd_R819A -- Iterative DO statement - ffestd_R527_start(); + ffestd_R819A(construct_name,label_token,expr,expr_token); - Verify that TARGET is valid here, and begin accepting items in the - list. */ + Make sure statement is valid here; implement. */ void -ffestd_R527_start () +ffestd_R819A (ffelexToken construct_name UNUSED, ffelab label, + ffebld var, ffebld start, ffelexToken start_token, + ffebld end, ffelexToken end_token, + ffebld incr, ffelexToken incr_token) { - ffestd_check_start_ (); + ffestdStmt_ stmt; - ffestd_subr_f90_ (); - return; + ffestd_check_simple_ (); -#ifdef FFESTD_F90 - fputs ("* TARGET ", dmpout); -#endif + stmt = ffestd_stmt_new_ (FFESTD_stmtidR819A_); + ffestd_stmt_append_ (stmt); + ffestd_subr_line_save_ (stmt); + stmt->u.R819A.pool = ffesta_output_pool; + stmt->u.R819A.block = ffestw_use (ffestw_stack_top ()); + stmt->u.R819A.label = label; + stmt->u.R819A.var = var; + stmt->u.R819A.start = start; + stmt->u.R819A.start_token = ffelex_token_use (start_token); + stmt->u.R819A.end = end; + stmt->u.R819A.end_token = ffelex_token_use (end_token); + stmt->u.R819A.incr = incr; + stmt->u.R819A.incr_token = (incr_token == NULL) ? NULL + : ffelex_token_use (incr_token); + ffesta_set_outpooldisp (FFESTA_pooldispPRESERVE); + + ++ffestd_block_level_; + assert (ffestd_block_level_ > 0); } -/* ffestd_R527_item -- TARGET statement for object-name +/* ffestd_R819B -- DO WHILE statement - ffestd_R527_item(name_token,dim_list); + ffestd_R819B(construct_name,label_token,expr,expr_token); - Make sure name_token identifies a valid object to be TARGETd. */ + Make sure statement is valid here; implement. */ void -ffestd_R527_item (ffelexToken name, ffesttDimList dims) +ffestd_R819B (ffelexToken construct_name UNUSED, ffelab label, + ffebld expr) { - ffestd_check_item_ (); + ffestdStmt_ stmt; - return; /* F90. */ + ffestd_check_simple_ (); -#ifdef FFESTD_F90 - fputs (ffelex_token_text (name), dmpout); - if (dims != NULL) - { - fputc ('(', dmpout); - ffestt_dimlist_dump (dims); - fputc (')', dmpout); - } - fputc (',', dmpout); -#endif + stmt = ffestd_stmt_new_ (FFESTD_stmtidR819B_); + ffestd_stmt_append_ (stmt); + ffestd_subr_line_save_ (stmt); + stmt->u.R819B.pool = ffesta_output_pool; + stmt->u.R819B.block = ffestw_use (ffestw_stack_top ()); + stmt->u.R819B.label = label; + stmt->u.R819B.expr = expr; + ffesta_set_outpooldisp (FFESTA_pooldispPRESERVE); + + ++ffestd_block_level_; + assert (ffestd_block_level_ > 0); } -/* ffestd_R527_finish -- TARGET statement list complete +/* ffestd_R825 -- END DO statement - ffestd_R527_finish(); + ffestd_R825(name_token); - Just wrap up any local activities. */ + Make sure ffestd_kind_ identifies a DO block. If not + NULL, make sure name_token gives the correct name. Do whatever + is specific to seeing END DO with a DO-target label definition on it, + where the END DO is really treated as a CONTINUE (i.e. generate th + same code you would for CONTINUE). ffestd_do handles the actual + generation of end-loop code. */ void -ffestd_R527_finish () +ffestd_R825 (ffelexToken name UNUSED) { - ffestd_check_finish_ (); + ffestdStmt_ stmt; - return; /* F90. */ + ffestd_check_simple_ (); -#ifdef FFESTD_F90 - fputc ('\n', dmpout); -#endif + stmt = ffestd_stmt_new_ (FFESTD_stmtidR825_); + ffestd_stmt_append_ (stmt); + ffestd_subr_line_save_ (stmt); } -#endif -/* ffestd_R537_start -- PARAMETER statement list begin +/* ffestd_R834 -- CYCLE statement - ffestd_R537_start(); + ffestd_R834(name_token); - Verify that PARAMETER is valid here, and begin accepting items in the list. */ + Handle a CYCLE within a loop. */ void -ffestd_R537_start () +ffestd_R834 (ffestw block) { - ffestd_check_start_ (); -} - -/* ffestd_R537_item -- PARAMETER statement assignment - - ffestd_R537_item(dest,dest_token,source,source_token); + ffestdStmt_ stmt; - Make sure the source is a valid source for the destination; make the - assignment. */ + ffestd_check_simple_ (); -void -ffestd_R537_item (ffebld dest UNUSED, ffebld source UNUSED) -{ - ffestd_check_item_ (); + stmt = ffestd_stmt_new_ (FFESTD_stmtidR834_); + ffestd_stmt_append_ (stmt); + ffestd_subr_line_save_ (stmt); + stmt->u.R834.block = block; } -/* ffestd_R537_finish -- PARAMETER statement list complete +/* ffestd_R835 -- EXIT statement - ffestd_R537_finish(); + ffestd_R835(name_token); - Just wrap up any local activities. */ + Handle a EXIT within a loop. */ void -ffestd_R537_finish () +ffestd_R835 (ffestw block) { - ffestd_check_finish_ (); -} - -/* ffestd_R539 -- IMPLICIT NONE statement - - ffestd_R539(); - - Verify that the IMPLICIT NONE statement is ok here and implement. */ + ffestdStmt_ stmt; -void -ffestd_R539 () -{ ffestd_check_simple_ (); + + stmt = ffestd_stmt_new_ (FFESTD_stmtidR835_); + ffestd_stmt_append_ (stmt); + ffestd_subr_line_save_ (stmt); + stmt->u.R835.block = block; } -/* ffestd_R539start -- IMPLICIT statement +/* ffestd_R836 -- GOTO statement - ffestd_R539start(); + ffestd_R836(label); - Verify that the IMPLICIT statement is ok here and implement. */ + Make sure label_token identifies a valid label for a GOTO. Update + that label's info to indicate it is the target of a GOTO. */ void -ffestd_R539start () +ffestd_R836 (ffelab label) { - ffestd_check_start_ (); -} - -/* ffestd_R539item -- IMPLICIT statement specification (R540) + ffestdStmt_ stmt; - ffestd_R539item(...); + ffestd_check_simple_ (); - Verify that the type and letter list are all ok and implement. */ + stmt = ffestd_stmt_new_ (FFESTD_stmtidR836_); + ffestd_stmt_append_ (stmt); + ffestd_subr_line_save_ (stmt); + stmt->u.R836.label = label; -void -ffestd_R539item (ffestpType type UNUSED, ffebld kind UNUSED, - ffelexToken kindt UNUSED, ffebld len UNUSED, - ffelexToken lent UNUSED, ffesttImpList letters UNUSED) -{ - ffestd_check_item_ (); + if (ffestd_block_level_ == 0) + ffestd_is_reachable_ = FALSE; } -/* ffestd_R539finish -- IMPLICIT statement +/* ffestd_R837 -- Computed GOTO statement - ffestd_R539finish(); + ffestd_R837(labels,expr); - Finish up any local activities. */ + Make sure label_list identifies valid labels for a GOTO. Update + each label's info to indicate it is the target of a GOTO. */ void -ffestd_R539finish () +ffestd_R837 (ffelab *labels, int count, ffebld expr) { - ffestd_check_finish_ (); -} - -/* ffestd_R542_start -- NAMELIST statement list begin - - ffestd_R542_start(); + ffestdStmt_ stmt; - Verify that NAMELIST is valid here, and begin accepting items in the list. */ + ffestd_check_simple_ (); -void -ffestd_R542_start () -{ - ffestd_check_start_ (); + stmt = ffestd_stmt_new_ (FFESTD_stmtidR837_); + ffestd_stmt_append_ (stmt); + ffestd_subr_line_save_ (stmt); + stmt->u.R837.pool = ffesta_output_pool; + stmt->u.R837.labels = labels; + stmt->u.R837.count = count; + stmt->u.R837.expr = expr; + ffesta_set_outpooldisp (FFESTA_pooldispPRESERVE); } -/* ffestd_R542_item_nlist -- NAMELIST statement for group-name +/* ffestd_R838 -- ASSIGN statement - ffestd_R542_item_nlist(groupname_token); + ffestd_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 -ffestd_R542_item_nlist (ffelexToken name UNUSED) +ffestd_R838 (ffelab label, ffebld target) { - ffestd_check_item_ (); -} - -/* ffestd_R542_item_nitem -- NAMELIST statement for variable-name - - ffestd_R542_item_nitem(name_token); + ffestdStmt_ stmt; - Make sure name_token identifies a valid object to be NAMELISTd. */ + ffestd_check_simple_ (); -void -ffestd_R542_item_nitem (ffelexToken name UNUSED) -{ - ffestd_check_item_ (); + stmt = ffestd_stmt_new_ (FFESTD_stmtidR838_); + ffestd_stmt_append_ (stmt); + ffestd_subr_line_save_ (stmt); + stmt->u.R838.pool = ffesta_output_pool; + stmt->u.R838.label = label; + stmt->u.R838.target = target; + ffesta_set_outpooldisp (FFESTA_pooldispPRESERVE); } -/* ffestd_R542_finish -- NAMELIST statement list complete +/* ffestd_R839 -- Assigned GOTO statement - ffestd_R542_finish(); + ffestd_R839(target,labels); - Just wrap up any local activities. */ + Make sure label_list identifies valid labels for a GOTO. Update + each label's info to indicate it is the target of a GOTO. */ void -ffestd_R542_finish () +ffestd_R839 (ffebld target, ffelab *labels UNUSED, int count UNUSED) { - ffestd_check_finish_ (); -} - -/* ffestd_R544_start -- EQUIVALENCE statement list begin + ffestdStmt_ stmt; - ffestd_R544_start(); + ffestd_check_simple_ (); - Verify that EQUIVALENCE is valid here, and begin accepting items in the - list. */ + stmt = ffestd_stmt_new_ (FFESTD_stmtidR839_); + ffestd_stmt_append_ (stmt); + ffestd_subr_line_save_ (stmt); + stmt->u.R839.pool = ffesta_output_pool; + stmt->u.R839.target = target; + ffesta_set_outpooldisp (FFESTA_pooldispPRESERVE); -#if 0 -void -ffestd_R544_start () -{ - ffestd_check_start_ (); + if (ffestd_block_level_ == 0) + ffestd_is_reachable_ = FALSE; } -#endif -/* ffestd_R544_item -- EQUIVALENCE statement assignment +/* ffestd_R840 -- Arithmetic IF statement - ffestd_R544_item(exprlist); + ffestd_R840(expr,expr_token,neg,zero,pos); - Make sure the equivalence is valid, then implement it. */ + Make sure the labels are valid; implement. */ -#if 0 void -ffestd_R544_item (ffesttExprList exprlist) +ffestd_R840 (ffebld expr, ffelab neg, ffelab zero, ffelab pos) { - ffestd_check_item_ (); -} - -#endif -/* ffestd_R544_finish -- EQUIVALENCE statement list complete + ffestdStmt_ stmt; - ffestd_R544_finish(); + ffestd_check_simple_ (); - Just wrap up any local activities. */ + stmt = ffestd_stmt_new_ (FFESTD_stmtidR840_); + ffestd_stmt_append_ (stmt); + ffestd_subr_line_save_ (stmt); + stmt->u.R840.pool = ffesta_output_pool; + stmt->u.R840.expr = expr; + stmt->u.R840.neg = neg; + stmt->u.R840.zero = zero; + stmt->u.R840.pos = pos; + ffesta_set_outpooldisp (FFESTA_pooldispPRESERVE); -#if 0 -void -ffestd_R544_finish () -{ - ffestd_check_finish_ (); + if (ffestd_block_level_ == 0) + ffestd_is_reachable_ = FALSE; } -#endif -/* ffestd_R547_start -- COMMON statement list begin - - ffestd_R547_start(); +/* ffestd_R841 -- CONTINUE statement - Verify that COMMON is valid here, and begin accepting items in the list. */ + ffestd_R841(); */ void -ffestd_R547_start () +ffestd_R841 (bool in_where UNUSED) { - ffestd_check_start_ (); -} + ffestdStmt_ stmt; -/* ffestd_R547_item_object -- COMMON statement for object-name + ffestd_check_simple_ (); - ffestd_R547_item_object(name_token,dim_list); + stmt = ffestd_stmt_new_ (FFESTD_stmtidR841_); + ffestd_stmt_append_ (stmt); + ffestd_subr_line_save_ (stmt); +} - Make sure name_token identifies a valid object to be COMMONd. */ +/* ffestd_R842 -- STOP statement + + ffestd_R842(expr); */ void -ffestd_R547_item_object (ffelexToken name UNUSED, - ffesttDimList dims UNUSED) +ffestd_R842 (ffebld expr) { - ffestd_check_item_ (); -} + ffestdStmt_ stmt; -/* ffestd_R547_item_cblock -- COMMON statement for common-block-name - - ffestd_R547_item_cblock(name_token); + ffestd_check_simple_ (); - Make sure name_token identifies a valid common block to be COMMONd. */ + stmt = ffestd_stmt_new_ (FFESTD_stmtidR842_); + ffestd_stmt_append_ (stmt); + ffestd_subr_line_save_ (stmt); + if (ffesta_outpooldisp () == FFESTA_pooldispPRESERVE) + { + /* This is a "spurious" (automatically-generated) STOP + that follows a previous STOP or other statement. + Make sure we don't have an expression in the pool, + and then mark that the pool has already been killed. */ + assert (expr == NULL); + stmt->u.R842.pool = NULL; + stmt->u.R842.expr = NULL; + } + else + { + stmt->u.R842.pool = ffesta_output_pool; + stmt->u.R842.expr = expr; + ffesta_set_outpooldisp (FFESTA_pooldispPRESERVE); + } -void -ffestd_R547_item_cblock (ffelexToken name UNUSED) -{ - ffestd_check_item_ (); + if (ffestd_block_level_ == 0) + ffestd_is_reachable_ = FALSE; } -/* ffestd_R547_finish -- COMMON statement list complete +/* ffestd_R843 -- PAUSE statement - ffestd_R547_finish(); + ffestd_R843(expr,expr_token); - Just wrap up any local activities. */ + Make sure statement is valid here; implement. expr and expr_token are + both NULL if there was no expression. */ void -ffestd_R547_finish () +ffestd_R843 (ffebld expr) { - ffestd_check_finish_ (); -} - -/* ffestd_R620 -- ALLOCATE statement - - ffestd_R620(exprlist,stat,stat_token); - - Make sure the expression list is valid, then implement it. */ + ffestdStmt_ stmt; -#if FFESTR_F90 -void -ffestd_R620 (ffesttExprList exprlist, ffebld stat) -{ ffestd_check_simple_ (); - ffestd_subr_f90_ (); + stmt = ffestd_stmt_new_ (FFESTD_stmtidR843_); + ffestd_stmt_append_ (stmt); + ffestd_subr_line_save_ (stmt); + stmt->u.R843.pool = ffesta_output_pool; + stmt->u.R843.expr = expr; + ffesta_set_outpooldisp (FFESTA_pooldispPRESERVE); } -/* ffestd_R624 -- NULLIFY statement +/* ffestd_R904 -- OPEN statement - ffestd_R624(pointer_name_list); + ffestd_R904(); - Make sure pointer_name_list identifies valid pointers for a NULLIFY. */ + Make sure an OPEN is valid in the current context, and implement it. */ void -ffestd_R624 (ffesttExprList pointers) +ffestd_R904 () { - ffestd_check_simple_ (); - - ffestd_subr_f90_ (); - return; + ffestdStmt_ stmt; -#ifdef FFESTD_F90 - fputs ("+ NULLIFY (", dmpout); - assert (pointers != NULL); - ffestt_exprlist_dump (pointers); - fputs (")\n", dmpout); -#endif -} + ffestd_check_simple_ (); -/* ffestd_R625 -- DEALLOCATE statement +#define specified(something) \ + (ffestp_file.open.open_spec[something].kw_or_val_present) - ffestd_R625(exprlist,stat,stat_token); + /* Warn if there are any thing we don't handle via f2c libraries. */ - Make sure the equivalence is valid, then implement it. */ + if (specified (FFESTP_openixACTION) + || specified (FFESTP_openixASSOCIATEVARIABLE) + || specified (FFESTP_openixBLOCKSIZE) + || specified (FFESTP_openixBUFFERCOUNT) + || specified (FFESTP_openixCARRIAGECONTROL) + || specified (FFESTP_openixDEFAULTFILE) + || specified (FFESTP_openixDELIM) + || specified (FFESTP_openixDISPOSE) + || specified (FFESTP_openixEXTENDSIZE) + || specified (FFESTP_openixINITIALSIZE) + || specified (FFESTP_openixKEY) + || specified (FFESTP_openixMAXREC) + || specified (FFESTP_openixNOSPANBLOCKS) + || specified (FFESTP_openixORGANIZATION) + || specified (FFESTP_openixPAD) + || specified (FFESTP_openixPOSITION) + || specified (FFESTP_openixREADONLY) + || specified (FFESTP_openixRECORDTYPE) + || specified (FFESTP_openixSHARED) + || specified (FFESTP_openixUSEROPEN)) + { + ffebad_start (FFEBAD_OPEN_UNSUPPORTED); + ffebad_here (0, ffelex_token_where_line (ffesta_tokens[0]), + ffelex_token_where_column (ffesta_tokens[0])); + ffebad_finish (); + } -void -ffestd_R625 (ffesttExprList exprlist, ffebld stat) -{ - ffestd_check_simple_ (); +#undef specified - ffestd_subr_f90_ (); + stmt = ffestd_stmt_new_ (FFESTD_stmtidR904_); + ffestd_stmt_append_ (stmt); + ffestd_subr_line_save_ (stmt); + stmt->u.R904.pool = ffesta_output_pool; + stmt->u.R904.params = ffestd_subr_copy_open_ (); + ffesta_set_outpooldisp (FFESTA_pooldispPRESERVE); } -#endif -/* ffestd_R737A -- Assignment statement outside of WHERE +/* ffestd_R907 -- CLOSE statement - ffestd_R737A(dest_expr,source_expr); */ + ffestd_R907(); + + Make sure a CLOSE is valid in the current context, and implement it. */ void -ffestd_R737A (ffebld dest, ffebld source) +ffestd_R907 () { ffestdStmt_ stmt; ffestd_check_simple_ (); - stmt = ffestd_stmt_new_ (FFESTD_stmtidR737A_); + stmt = ffestd_stmt_new_ (FFESTD_stmtidR907_); ffestd_stmt_append_ (stmt); ffestd_subr_line_save_ (stmt); - stmt->u.R737A.pool = ffesta_output_pool; - stmt->u.R737A.dest = dest; - stmt->u.R737A.source = source; + stmt->u.R907.pool = ffesta_output_pool; + stmt->u.R907.params = ffestd_subr_copy_close_ (); ffesta_set_outpooldisp (FFESTA_pooldispPRESERVE); } -/* ffestd_R737B -- Assignment statement inside of WHERE +/* ffestd_R909_start -- READ(...) statement list begin + + ffestd_R909_start(FALSE); - ffestd_R737B(dest_expr,source_expr); */ + Verify that READ is valid here, and begin accepting items in the + list. */ -#if FFESTR_F90 void -ffestd_R737B (ffebld dest, ffebld source) +ffestd_R909_start (bool only_format, ffestvUnit unit, + ffestvFormat format, bool rec, bool key) { - ffestd_check_simple_ (); -} + ffestdStmt_ stmt; -/* ffestd_R738 -- Pointer assignment statement + ffestd_check_start_ (); - ffestd_R738(dest_expr,source_expr,source_token); +#define specified(something) \ + (ffestp_file.read.read_spec[something].kw_or_val_present) - Make sure the assignment is valid. */ + /* Warn if there are any thing we don't handle via f2c libraries. */ + if (specified (FFESTP_readixADVANCE) + || specified (FFESTP_readixEOR) + || specified (FFESTP_readixKEYEQ) + || specified (FFESTP_readixKEYGE) + || specified (FFESTP_readixKEYGT) + || specified (FFESTP_readixKEYID) + || specified (FFESTP_readixNULLS) + || specified (FFESTP_readixSIZE)) + { + ffebad_start (FFEBAD_READ_UNSUPPORTED); + ffebad_here (0, ffelex_token_where_line (ffesta_tokens[0]), + ffelex_token_where_column (ffesta_tokens[0])); + ffebad_finish (); + } -void -ffestd_R738 (ffebld dest, ffebld source) -{ - ffestd_check_simple_ (); +#undef specified - ffestd_subr_f90_ (); + stmt = ffestd_stmt_new_ (FFESTD_stmtidR909_); + ffestd_stmt_append_ (stmt); + ffestd_subr_line_save_ (stmt); + stmt->u.R909.pool = ffesta_output_pool; + stmt->u.R909.params = ffestd_subr_copy_read_ (); + stmt->u.R909.only_format = only_format; + stmt->u.R909.unit = unit; + stmt->u.R909.format = format; + stmt->u.R909.rec = rec; + stmt->u.R909.key = key; + stmt->u.R909.list = NULL; + ffestd_expr_list_ = &stmt->u.R909.list; + ffesta_set_outpooldisp (FFESTA_pooldispPRESERVE); } -/* ffestd_R740 -- WHERE statement +/* ffestd_R909_item -- READ statement i/o item - ffestd_R740(expr,expr_token); + ffestd_R909_item(expr,expr_token); - Make sure statement is valid here; implement. */ + Implement output-list expression. */ void -ffestd_R740 (ffebld expr) +ffestd_R909_item (ffebld expr, ffelexToken expr_token) { - ffestd_check_simple_ (); + ffestdExprItem_ item; + + ffestd_check_item_ (); + + item = (ffestdExprItem_) malloc_new_kp (ffesta_output_pool, + "ffestdExprItem_", sizeof (*item)); - ffestd_subr_f90_ (); + item->next = NULL; + item->expr = expr; + item->token = ffelex_token_use (expr_token); + *ffestd_expr_list_ = item; + ffestd_expr_list_ = &item->next; } -/* ffestd_R742 -- WHERE-construct statement +/* ffestd_R909_finish -- READ statement list complete - ffestd_R742(expr,expr_token); + ffestd_R909_finish(); - Make sure statement is valid here; implement. */ + Just wrap up any local activities. */ void -ffestd_R742 (ffebld expr) +ffestd_R909_finish () { - ffestd_check_simple_ (); - - ffestd_subr_f90_ (); + ffestd_check_finish_ (); } -/* ffestd_R744 -- ELSE WHERE statement +/* ffestd_R910_start -- WRITE(...) statement list begin - ffestd_R744(); + ffestd_R910_start(); - Make sure ffestd_kind_ identifies a WHERE block. - Implement the ELSE of the current WHERE block. */ + Verify that WRITE is valid here, and begin accepting items in the + list. */ void -ffestd_R744 () +ffestd_R910_start (ffestvUnit unit, ffestvFormat format, bool rec) { - ffestd_check_simple_ (); - - return; /* F90. */ + ffestdStmt_ stmt; -#ifdef FFESTD_F90 - fputs ("+ ELSE_WHERE\n", dmpout); -#endif -} + ffestd_check_start_ (); -/* ffestd_R745 -- Implicit END WHERE statement. */ +#define specified(something) \ + (ffestp_file.write.write_spec[something].kw_or_val_present) -void -ffestd_R745 (bool ok) -{ - return; /* F90. */ + /* Warn if there are any thing we don't handle via f2c libraries. */ + if (specified (FFESTP_writeixADVANCE) + || specified (FFESTP_writeixEOR)) + { + ffebad_start (FFEBAD_WRITE_UNSUPPORTED); + ffebad_here (0, ffelex_token_where_line (ffesta_tokens[0]), + ffelex_token_where_column (ffesta_tokens[0])); + ffebad_finish (); + } -#ifdef FFESTD_F90 - fputs ("+ END_WHERE\n", dmpout); /* Also see ffestd_R745. */ +#undef specified - --ffestd_block_level_; - assert (ffestd_block_level_ >= 0); -#endif + stmt = ffestd_stmt_new_ (FFESTD_stmtidR910_); + ffestd_stmt_append_ (stmt); + ffestd_subr_line_save_ (stmt); + stmt->u.R910.pool = ffesta_output_pool; + stmt->u.R910.params = ffestd_subr_copy_write_ (); + stmt->u.R910.unit = unit; + stmt->u.R910.format = format; + stmt->u.R910.rec = rec; + stmt->u.R910.list = NULL; + ffestd_expr_list_ = &stmt->u.R910.list; + ffesta_set_outpooldisp (FFESTA_pooldispPRESERVE); } -#endif +/* ffestd_R910_item -- WRITE statement i/o item -/* Block IF (IF-THEN) statement. */ + ffestd_R910_item(expr,expr_token); + + Implement output-list expression. */ void -ffestd_R803 (ffelexToken construct_name UNUSED, ffebld expr) +ffestd_R910_item (ffebld expr, ffelexToken expr_token) { - ffestdStmt_ stmt; + ffestdExprItem_ item; - ffestd_check_simple_ (); + ffestd_check_item_ (); - stmt = ffestd_stmt_new_ (FFESTD_stmtidR803_); - ffestd_stmt_append_ (stmt); - ffestd_subr_line_save_ (stmt); - stmt->u.R803.pool = ffesta_output_pool; - stmt->u.R803.block = ffestw_use (ffestw_stack_top ()); - stmt->u.R803.expr = expr; - ffesta_set_outpooldisp (FFESTA_pooldispPRESERVE); + item = (ffestdExprItem_) malloc_new_kp (ffesta_output_pool, + "ffestdExprItem_", sizeof (*item)); - ++ffestd_block_level_; - assert (ffestd_block_level_ > 0); + item->next = NULL; + item->expr = expr; + item->token = ffelex_token_use (expr_token); + *ffestd_expr_list_ = item; + ffestd_expr_list_ = &item->next; } -/* ELSE IF statement. */ +/* ffestd_R910_finish -- WRITE statement list complete + + ffestd_R910_finish(); + + Just wrap up any local activities. */ void -ffestd_R804 (ffebld expr, ffelexToken name UNUSED) +ffestd_R910_finish () { - ffestdStmt_ stmt; + ffestd_check_finish_ (); +} - ffestd_check_simple_ (); +/* ffestd_R911_start -- PRINT statement list begin - stmt = ffestd_stmt_new_ (FFESTD_stmtidR804_); - ffestd_stmt_append_ (stmt); - ffestd_subr_line_save_ (stmt); - stmt->u.R804.pool = ffesta_output_pool; - stmt->u.R804.block = ffestw_use (ffestw_stack_top ()); - stmt->u.R804.expr = expr; - ffesta_set_outpooldisp (FFESTA_pooldispPRESERVE); -} + ffestd_R911_start(); -/* ELSE statement. */ + Verify that PRINT is valid here, and begin accepting items in the + list. */ void -ffestd_R805 (ffelexToken name UNUSED) +ffestd_R911_start (ffestvFormat format) { ffestdStmt_ stmt; - ffestd_check_simple_ (); + ffestd_check_start_ (); - stmt = ffestd_stmt_new_ (FFESTD_stmtidR805_); + stmt = ffestd_stmt_new_ (FFESTD_stmtidR911_); ffestd_stmt_append_ (stmt); ffestd_subr_line_save_ (stmt); - stmt->u.R805.block = ffestw_use (ffestw_stack_top ()); + stmt->u.R911.pool = ffesta_output_pool; + stmt->u.R911.params = ffestd_subr_copy_print_ (); + stmt->u.R911.format = format; + stmt->u.R911.list = NULL; + ffestd_expr_list_ = &stmt->u.R911.list; + ffesta_set_outpooldisp (FFESTA_pooldispPRESERVE); } -/* END IF statement. */ +/* ffestd_R911_item -- PRINT statement i/o item + + ffestd_R911_item(expr,expr_token); + + Implement output-list expression. */ void -ffestd_R806 (bool ok UNUSED) +ffestd_R911_item (ffebld expr, ffelexToken expr_token) { - ffestdStmt_ stmt; + ffestdExprItem_ item; - stmt = ffestd_stmt_new_ (FFESTD_stmtidR806_); - ffestd_stmt_append_ (stmt); - ffestd_subr_line_save_ (stmt); - stmt->u.R806.block = ffestw_use (ffestw_stack_top ()); + ffestd_check_item_ (); - --ffestd_block_level_; - assert (ffestd_block_level_ >= 0); + item = (ffestdExprItem_) malloc_new_kp (ffesta_output_pool, + "ffestdExprItem_", sizeof (*item)); + + item->next = NULL; + item->expr = expr; + item->token = ffelex_token_use (expr_token); + *ffestd_expr_list_ = item; + ffestd_expr_list_ = &item->next; } -/* ffestd_R807 -- Logical IF statement +/* ffestd_R911_finish -- PRINT statement list complete - ffestd_R807(expr,expr_token); + ffestd_R911_finish(); - Make sure statement is valid here; implement. */ + Just wrap up any local activities. */ void -ffestd_R807 (ffebld expr) +ffestd_R911_finish () { - ffestdStmt_ stmt; - - ffestd_check_simple_ (); - - stmt = ffestd_stmt_new_ (FFESTD_stmtidR807_); - ffestd_stmt_append_ (stmt); - ffestd_subr_line_save_ (stmt); - stmt->u.R807.pool = ffesta_output_pool; - stmt->u.R807.expr = expr; - ffesta_set_outpooldisp (FFESTA_pooldispPRESERVE); - - ++ffestd_block_level_; - assert (ffestd_block_level_ > 0); + ffestd_check_finish_ (); } -/* ffestd_R809 -- SELECT CASE statement +/* ffestd_R919 -- BACKSPACE statement - ffestd_R809(construct_name,expr,expr_token); + ffestd_R919(); - Make sure statement is valid here; implement. */ + Make sure a BACKSPACE is valid in the current context, and implement it. */ void -ffestd_R809 (ffelexToken construct_name UNUSED, ffebld expr) +ffestd_R919 () { ffestdStmt_ stmt; ffestd_check_simple_ (); - stmt = ffestd_stmt_new_ (FFESTD_stmtidR809_); + stmt = ffestd_stmt_new_ (FFESTD_stmtidR919_); ffestd_stmt_append_ (stmt); ffestd_subr_line_save_ (stmt); - stmt->u.R809.pool = ffesta_output_pool; - stmt->u.R809.block = ffestw_use (ffestw_stack_top ()); - stmt->u.R809.expr = expr; + stmt->u.R919.pool = ffesta_output_pool; + stmt->u.R919.params = ffestd_subr_copy_beru_ (); ffesta_set_outpooldisp (FFESTA_pooldispPRESERVE); - malloc_pool_use (ffestw_select (ffestw_stack_top ())->pool); - - ++ffestd_block_level_; - assert (ffestd_block_level_ > 0); } -/* ffestd_R810 -- CASE statement +/* ffestd_R920 -- ENDFILE statement - ffestd_R810(case_value_range_list,name); + ffestd_R920(); - If casenum is 0, it's CASE DEFAULT. Else it's the case ranges at - the start of the first_stmt list in the select object at the top of - the stack that match casenum. */ + Make sure a ENDFILE is valid in the current context, and implement it. */ void -ffestd_R810 (unsigned long casenum) +ffestd_R920 () { ffestdStmt_ stmt; ffestd_check_simple_ (); - stmt = ffestd_stmt_new_ (FFESTD_stmtidR810_); + stmt = ffestd_stmt_new_ (FFESTD_stmtidR920_); ffestd_stmt_append_ (stmt); ffestd_subr_line_save_ (stmt); - stmt->u.R810.pool = ffesta_output_pool; - stmt->u.R810.block = ffestw_stack_top (); - stmt->u.R810.casenum = casenum; + stmt->u.R920.pool = ffesta_output_pool; + stmt->u.R920.params = ffestd_subr_copy_beru_ (); ffesta_set_outpooldisp (FFESTA_pooldispPRESERVE); } -/* ffestd_R811 -- End a SELECT +/* ffestd_R921 -- REWIND statement - ffestd_R811(TRUE); */ + ffestd_R921(); + + Make sure a REWIND is valid in the current context, and implement it. */ void -ffestd_R811 (bool ok UNUSED) +ffestd_R921 () { ffestdStmt_ stmt; - stmt = ffestd_stmt_new_ (FFESTD_stmtidR811_); + ffestd_check_simple_ (); + + stmt = ffestd_stmt_new_ (FFESTD_stmtidR921_); ffestd_stmt_append_ (stmt); ffestd_subr_line_save_ (stmt); - stmt->u.R811.block = ffestw_stack_top (); - - --ffestd_block_level_; - assert (ffestd_block_level_ >= 0); + stmt->u.R921.pool = ffesta_output_pool; + stmt->u.R921.params = ffestd_subr_copy_beru_ (); + ffesta_set_outpooldisp (FFESTA_pooldispPRESERVE); } -/* ffestd_R819A -- Iterative DO statement +/* ffestd_R923A -- INQUIRE statement (non-IOLENGTH version) - ffestd_R819A(construct_name,label_token,expr,expr_token); + ffestd_R923A(bool by_file); - Make sure statement is valid here; implement. */ + Make sure an INQUIRE is valid in the current context, and implement it. */ void -ffestd_R819A (ffelexToken construct_name UNUSED, ffelab label, - ffebld var, ffebld start, ffelexToken start_token, - ffebld end, ffelexToken end_token, - ffebld incr, ffelexToken incr_token) +ffestd_R923A (bool by_file) { ffestdStmt_ stmt; ffestd_check_simple_ (); - stmt = ffestd_stmt_new_ (FFESTD_stmtidR819A_); +#define specified(something) \ + (ffestp_file.inquire.inquire_spec[something].kw_or_val_present) + + /* Warn if there are any thing we don't handle via f2c libraries. */ + if (specified (FFESTP_inquireixACTION) + || specified (FFESTP_inquireixCARRIAGECONTROL) + || specified (FFESTP_inquireixDEFAULTFILE) + || specified (FFESTP_inquireixDELIM) + || specified (FFESTP_inquireixKEYED) + || specified (FFESTP_inquireixORGANIZATION) + || specified (FFESTP_inquireixPAD) + || specified (FFESTP_inquireixPOSITION) + || specified (FFESTP_inquireixREAD) + || specified (FFESTP_inquireixREADWRITE) + || specified (FFESTP_inquireixRECORDTYPE) + || specified (FFESTP_inquireixWRITE)) + { + ffebad_start (FFEBAD_INQUIRE_UNSUPPORTED); + ffebad_here (0, ffelex_token_where_line (ffesta_tokens[0]), + ffelex_token_where_column (ffesta_tokens[0])); + ffebad_finish (); + } + +#undef specified + + stmt = ffestd_stmt_new_ (FFESTD_stmtidR923A_); ffestd_stmt_append_ (stmt); ffestd_subr_line_save_ (stmt); - stmt->u.R819A.pool = ffesta_output_pool; - stmt->u.R819A.block = ffestw_use (ffestw_stack_top ()); - stmt->u.R819A.label = label; - stmt->u.R819A.var = var; - stmt->u.R819A.start = start; - stmt->u.R819A.start_token = ffelex_token_use (start_token); - stmt->u.R819A.end = end; - stmt->u.R819A.end_token = ffelex_token_use (end_token); - stmt->u.R819A.incr = incr; - stmt->u.R819A.incr_token = (incr_token == NULL) ? NULL - : ffelex_token_use (incr_token); + stmt->u.R923A.pool = ffesta_output_pool; + stmt->u.R923A.params = ffestd_subr_copy_inquire_ (); + stmt->u.R923A.by_file = by_file; ffesta_set_outpooldisp (FFESTA_pooldispPRESERVE); - - ++ffestd_block_level_; - assert (ffestd_block_level_ > 0); } -/* ffestd_R819B -- DO WHILE statement +/* ffestd_R923B_start -- INQUIRE(IOLENGTH=expr) statement list begin - ffestd_R819B(construct_name,label_token,expr,expr_token); + ffestd_R923B_start(); - Make sure statement is valid here; implement. */ + Verify that INQUIRE is valid here, and begin accepting items in the + list. */ void -ffestd_R819B (ffelexToken construct_name UNUSED, ffelab label, - ffebld expr) +ffestd_R923B_start () { ffestdStmt_ stmt; - ffestd_check_simple_ (); + ffestd_check_start_ (); - stmt = ffestd_stmt_new_ (FFESTD_stmtidR819B_); + stmt = ffestd_stmt_new_ (FFESTD_stmtidR923B_); ffestd_stmt_append_ (stmt); ffestd_subr_line_save_ (stmt); - stmt->u.R819B.pool = ffesta_output_pool; - stmt->u.R819B.block = ffestw_use (ffestw_stack_top ()); - stmt->u.R819B.label = label; - stmt->u.R819B.expr = expr; + stmt->u.R923B.pool = ffesta_output_pool; + stmt->u.R923B.params = ffestd_subr_copy_inquire_ (); + stmt->u.R923B.list = NULL; + ffestd_expr_list_ = &stmt->u.R923B.list; ffesta_set_outpooldisp (FFESTA_pooldispPRESERVE); - - ++ffestd_block_level_; - assert (ffestd_block_level_ > 0); } -/* ffestd_R825 -- END DO statement +/* ffestd_R923B_item -- INQUIRE statement i/o item - ffestd_R825(name_token); + ffestd_R923B_item(expr,expr_token); - Make sure ffestd_kind_ identifies a DO block. If not - NULL, make sure name_token gives the correct name. Do whatever - is specific to seeing END DO with a DO-target label definition on it, - where the END DO is really treated as a CONTINUE (i.e. generate th - same code you would for CONTINUE). ffestd_do handles the actual - generation of end-loop code. */ + Implement output-list expression. */ void -ffestd_R825 (ffelexToken name UNUSED) +ffestd_R923B_item (ffebld expr) { - ffestdStmt_ stmt; + ffestdExprItem_ item; - ffestd_check_simple_ (); + ffestd_check_item_ (); - stmt = ffestd_stmt_new_ (FFESTD_stmtidR825_); - ffestd_stmt_append_ (stmt); - ffestd_subr_line_save_ (stmt); + item = (ffestdExprItem_) malloc_new_kp (ffesta_output_pool, + "ffestdExprItem_", sizeof (*item)); + + item->next = NULL; + item->expr = expr; + *ffestd_expr_list_ = item; + ffestd_expr_list_ = &item->next; } -/* ffestd_R834 -- CYCLE statement +/* ffestd_R923B_finish -- INQUIRE statement list complete - ffestd_R834(name_token); + ffestd_R923B_finish(); - Handle a CYCLE within a loop. */ + Just wrap up any local activities. */ void -ffestd_R834 (ffestw block) +ffestd_R923B_finish () { - ffestdStmt_ stmt; + ffestd_check_finish_ (); +} - ffestd_check_simple_ (); - - stmt = ffestd_stmt_new_ (FFESTD_stmtidR834_); - ffestd_stmt_append_ (stmt); - ffestd_subr_line_save_ (stmt); - stmt->u.R834.block = block; -} - -/* ffestd_R835 -- EXIT statement - - ffestd_R835(name_token); - - Handle a EXIT within a loop. */ - -void -ffestd_R835 (ffestw block) -{ - ffestdStmt_ stmt; - - ffestd_check_simple_ (); - - stmt = ffestd_stmt_new_ (FFESTD_stmtidR835_); - ffestd_stmt_append_ (stmt); - ffestd_subr_line_save_ (stmt); - stmt->u.R835.block = block; -} - -/* ffestd_R836 -- GOTO statement - - ffestd_R836(label); - - Make sure label_token identifies a valid label for a GOTO. Update - that label's info to indicate it is the target of a GOTO. */ - -void -ffestd_R836 (ffelab label) -{ - ffestdStmt_ stmt; - - ffestd_check_simple_ (); - - stmt = ffestd_stmt_new_ (FFESTD_stmtidR836_); - ffestd_stmt_append_ (stmt); - ffestd_subr_line_save_ (stmt); - stmt->u.R836.label = label; - - if (ffestd_block_level_ == 0) - ffestd_is_reachable_ = FALSE; -} - -/* ffestd_R837 -- Computed GOTO statement - - ffestd_R837(labels,expr); - - Make sure label_list identifies valid labels for a GOTO. Update - each label's info to indicate it is the target of a GOTO. */ - -void -ffestd_R837 (ffelab *labels, int count, ffebld expr) -{ - ffestdStmt_ stmt; - - ffestd_check_simple_ (); - - stmt = ffestd_stmt_new_ (FFESTD_stmtidR837_); - ffestd_stmt_append_ (stmt); - ffestd_subr_line_save_ (stmt); - stmt->u.R837.pool = ffesta_output_pool; - stmt->u.R837.labels = labels; - stmt->u.R837.count = count; - stmt->u.R837.expr = expr; - ffesta_set_outpooldisp (FFESTA_pooldispPRESERVE); -} - -/* ffestd_R838 -- ASSIGN statement - - ffestd_R838(label_token,target_variable,target_token); - - Make sure label_token identifies a valid label for an assignment. Update - that label's info to indicate it is the source of an assignment. Update - target_variable's info to indicate it is the target the assignment of that - label. */ - -void -ffestd_R838 (ffelab label, ffebld target) -{ - ffestdStmt_ stmt; - - ffestd_check_simple_ (); - - stmt = ffestd_stmt_new_ (FFESTD_stmtidR838_); - ffestd_stmt_append_ (stmt); - ffestd_subr_line_save_ (stmt); - stmt->u.R838.pool = ffesta_output_pool; - stmt->u.R838.label = label; - stmt->u.R838.target = target; - ffesta_set_outpooldisp (FFESTA_pooldispPRESERVE); -} - -/* ffestd_R839 -- Assigned GOTO statement - - ffestd_R839(target,labels); - - Make sure label_list identifies valid labels for a GOTO. Update - each label's info to indicate it is the target of a GOTO. */ - -void -ffestd_R839 (ffebld target, ffelab *labels UNUSED, int count UNUSED) -{ - ffestdStmt_ stmt; - - ffestd_check_simple_ (); - - stmt = ffestd_stmt_new_ (FFESTD_stmtidR839_); - ffestd_stmt_append_ (stmt); - ffestd_subr_line_save_ (stmt); - stmt->u.R839.pool = ffesta_output_pool; - stmt->u.R839.target = target; - ffesta_set_outpooldisp (FFESTA_pooldispPRESERVE); - - if (ffestd_block_level_ == 0) - ffestd_is_reachable_ = FALSE; -} - -/* ffestd_R840 -- Arithmetic IF statement - - ffestd_R840(expr,expr_token,neg,zero,pos); - - Make sure the labels are valid; implement. */ - -void -ffestd_R840 (ffebld expr, ffelab neg, ffelab zero, ffelab pos) -{ - ffestdStmt_ stmt; - - ffestd_check_simple_ (); - - stmt = ffestd_stmt_new_ (FFESTD_stmtidR840_); - ffestd_stmt_append_ (stmt); - ffestd_subr_line_save_ (stmt); - stmt->u.R840.pool = ffesta_output_pool; - stmt->u.R840.expr = expr; - stmt->u.R840.neg = neg; - stmt->u.R840.zero = zero; - stmt->u.R840.pos = pos; - ffesta_set_outpooldisp (FFESTA_pooldispPRESERVE); - - if (ffestd_block_level_ == 0) - ffestd_is_reachable_ = FALSE; -} - -/* ffestd_R841 -- CONTINUE statement +/* ffestd_R1001 -- FORMAT statement - ffestd_R841(); */ + ffestd_R1001(format_list); */ void -ffestd_R841 (bool in_where UNUSED) +ffestd_R1001 (ffesttFormatList f) { + ffestsHolder str; + ffests s = &str; ffestdStmt_ stmt; ffestd_check_simple_ (); - stmt = ffestd_stmt_new_ (FFESTD_stmtidR841_); - ffestd_stmt_append_ (stmt); - ffestd_subr_line_save_ (stmt); -} - -/* ffestd_R842 -- STOP statement - - ffestd_R842(expr); */ - -void -ffestd_R842 (ffebld expr) -{ - ffestdStmt_ stmt; + if (ffestd_label_formatdef_ == NULL) + return; /* Nothing to hook it up to (no label def). */ - ffestd_check_simple_ (); + ffests_new (s, malloc_pool_image (), 80); + ffests_putc (s, '('); + ffestd_R1001dump_ (s, f); /* Build the string in s. */ + ffests_putc (s, ')'); - stmt = ffestd_stmt_new_ (FFESTD_stmtidR842_); + stmt = ffestd_stmt_new_ (FFESTD_stmtidR1001_); ffestd_stmt_append_ (stmt); - ffestd_subr_line_save_ (stmt); - if (ffesta_outpooldisp () == FFESTA_pooldispPRESERVE) - { - /* This is a "spurious" (automatically-generated) STOP - that follows a previous STOP or other statement. - Make sure we don't have an expression in the pool, - and then mark that the pool has already been killed. */ - assert (expr == NULL); - stmt->u.R842.pool = NULL; - stmt->u.R842.expr = NULL; - } - else - { - stmt->u.R842.pool = ffesta_output_pool; - stmt->u.R842.expr = expr; - ffesta_set_outpooldisp (FFESTA_pooldispPRESERVE); - } - - if (ffestd_block_level_ == 0) - ffestd_is_reachable_ = FALSE; -} - -/* ffestd_R843 -- PAUSE statement - - ffestd_R843(expr,expr_token); - - Make sure statement is valid here; implement. expr and expr_token are - both NULL if there was no expression. */ - -void -ffestd_R843 (ffebld expr) -{ - ffestdStmt_ stmt; - - ffestd_check_simple_ (); + stmt->u.R1001.str = str; - stmt = ffestd_stmt_new_ (FFESTD_stmtidR843_); - ffestd_stmt_append_ (stmt); - ffestd_subr_line_save_ (stmt); - stmt->u.R843.pool = ffesta_output_pool; - stmt->u.R843.expr = expr; - ffesta_set_outpooldisp (FFESTA_pooldispPRESERVE); + ffestd_label_formatdef_ = NULL; } -/* ffestd_R904 -- OPEN statement +/* ffestd_R1001dump_ -- Dump list of formats - ffestd_R904(); + ffesttFormatList list; + ffestd_R1001dump_(list,0); - Make sure an OPEN is valid in the current context, and implement it. */ + The formats in the list are dumped. */ -void -ffestd_R904 () +static void +ffestd_R1001dump_ (ffests s, ffesttFormatList list) { - ffestdStmt_ stmt; - - ffestd_check_simple_ (); - -#define specified(something) \ - (ffestp_file.open.open_spec[something].kw_or_val_present) - - /* Warn if there are any thing we don't handle via f2c libraries. */ - - if (specified (FFESTP_openixACTION) - || specified (FFESTP_openixASSOCIATEVARIABLE) - || specified (FFESTP_openixBLOCKSIZE) - || specified (FFESTP_openixBUFFERCOUNT) - || specified (FFESTP_openixCARRIAGECONTROL) - || specified (FFESTP_openixDEFAULTFILE) - || specified (FFESTP_openixDELIM) - || specified (FFESTP_openixDISPOSE) - || specified (FFESTP_openixEXTENDSIZE) - || specified (FFESTP_openixINITIALSIZE) - || specified (FFESTP_openixKEY) - || specified (FFESTP_openixMAXREC) - || specified (FFESTP_openixNOSPANBLOCKS) - || specified (FFESTP_openixORGANIZATION) - || specified (FFESTP_openixPAD) - || specified (FFESTP_openixPOSITION) - || specified (FFESTP_openixREADONLY) - || specified (FFESTP_openixRECORDTYPE) - || specified (FFESTP_openixSHARED) - || specified (FFESTP_openixUSEROPEN)) - { - ffebad_start (FFEBAD_OPEN_UNSUPPORTED); - ffebad_here (0, ffelex_token_where_line (ffesta_tokens[0]), - ffelex_token_where_column (ffesta_tokens[0])); - ffebad_finish (); - } - -#undef specified - - stmt = ffestd_stmt_new_ (FFESTD_stmtidR904_); - ffestd_stmt_append_ (stmt); - ffestd_subr_line_save_ (stmt); - stmt->u.R904.pool = ffesta_output_pool; - stmt->u.R904.params = ffestd_subr_copy_open_ (); - ffesta_set_outpooldisp (FFESTA_pooldispPRESERVE); -} - -/* ffestd_R907 -- CLOSE statement - - ffestd_R907(); - - Make sure a CLOSE is valid in the current context, and implement it. */ - -void -ffestd_R907 () -{ - ffestdStmt_ stmt; - - ffestd_check_simple_ (); - - stmt = ffestd_stmt_new_ (FFESTD_stmtidR907_); - ffestd_stmt_append_ (stmt); - ffestd_subr_line_save_ (stmt); - stmt->u.R907.pool = ffesta_output_pool; - stmt->u.R907.params = ffestd_subr_copy_close_ (); - ffesta_set_outpooldisp (FFESTA_pooldispPRESERVE); -} - -/* ffestd_R909_start -- READ(...) statement list begin - - ffestd_R909_start(FALSE); - - Verify that READ is valid here, and begin accepting items in the - list. */ - -void -ffestd_R909_start (bool only_format, ffestvUnit unit, - ffestvFormat format, bool rec, bool key) -{ - ffestdStmt_ stmt; - - ffestd_check_start_ (); - -#define specified(something) \ - (ffestp_file.read.read_spec[something].kw_or_val_present) - - /* Warn if there are any thing we don't handle via f2c libraries. */ - if (specified (FFESTP_readixADVANCE) - || specified (FFESTP_readixEOR) - || specified (FFESTP_readixKEYEQ) - || specified (FFESTP_readixKEYGE) - || specified (FFESTP_readixKEYGT) - || specified (FFESTP_readixKEYID) - || specified (FFESTP_readixNULLS) - || specified (FFESTP_readixSIZE)) - { - ffebad_start (FFEBAD_READ_UNSUPPORTED); - ffebad_here (0, ffelex_token_where_line (ffesta_tokens[0]), - ffelex_token_where_column (ffesta_tokens[0])); - ffebad_finish (); - } - -#undef specified - - stmt = ffestd_stmt_new_ (FFESTD_stmtidR909_); - ffestd_stmt_append_ (stmt); - ffestd_subr_line_save_ (stmt); - stmt->u.R909.pool = ffesta_output_pool; - stmt->u.R909.params = ffestd_subr_copy_read_ (); - stmt->u.R909.only_format = only_format; - stmt->u.R909.unit = unit; - stmt->u.R909.format = format; - stmt->u.R909.rec = rec; - stmt->u.R909.key = key; - stmt->u.R909.list = NULL; - ffestd_expr_list_ = &stmt->u.R909.list; - ffesta_set_outpooldisp (FFESTA_pooldispPRESERVE); -} - -/* ffestd_R909_item -- READ statement i/o item - - ffestd_R909_item(expr,expr_token); - - Implement output-list expression. */ - -void -ffestd_R909_item (ffebld expr, ffelexToken expr_token) -{ - ffestdExprItem_ item; - - ffestd_check_item_ (); - - item = (ffestdExprItem_) malloc_new_kp (ffesta_output_pool, - "ffestdExprItem_", sizeof (*item)); - - item->next = NULL; - item->expr = expr; - item->token = ffelex_token_use (expr_token); - *ffestd_expr_list_ = item; - ffestd_expr_list_ = &item->next; -} - -/* ffestd_R909_finish -- READ statement list complete - - ffestd_R909_finish(); - - Just wrap up any local activities. */ - -void -ffestd_R909_finish () -{ - ffestd_check_finish_ (); -} - -/* ffestd_R910_start -- WRITE(...) statement list begin - - ffestd_R910_start(); - - Verify that WRITE is valid here, and begin accepting items in the - list. */ - -void -ffestd_R910_start (ffestvUnit unit, ffestvFormat format, bool rec) -{ - ffestdStmt_ stmt; - - ffestd_check_start_ (); - -#define specified(something) \ - (ffestp_file.write.write_spec[something].kw_or_val_present) - - /* Warn if there are any thing we don't handle via f2c libraries. */ - if (specified (FFESTP_writeixADVANCE) - || specified (FFESTP_writeixEOR)) - { - ffebad_start (FFEBAD_WRITE_UNSUPPORTED); - ffebad_here (0, ffelex_token_where_line (ffesta_tokens[0]), - ffelex_token_where_column (ffesta_tokens[0])); - ffebad_finish (); - } - -#undef specified - - stmt = ffestd_stmt_new_ (FFESTD_stmtidR910_); - ffestd_stmt_append_ (stmt); - ffestd_subr_line_save_ (stmt); - stmt->u.R910.pool = ffesta_output_pool; - stmt->u.R910.params = ffestd_subr_copy_write_ (); - stmt->u.R910.unit = unit; - stmt->u.R910.format = format; - stmt->u.R910.rec = rec; - stmt->u.R910.list = NULL; - ffestd_expr_list_ = &stmt->u.R910.list; - ffesta_set_outpooldisp (FFESTA_pooldispPRESERVE); -} - -/* ffestd_R910_item -- WRITE statement i/o item - - ffestd_R910_item(expr,expr_token); - - Implement output-list expression. */ - -void -ffestd_R910_item (ffebld expr, ffelexToken expr_token) -{ - ffestdExprItem_ item; - - ffestd_check_item_ (); - - item = (ffestdExprItem_) malloc_new_kp (ffesta_output_pool, - "ffestdExprItem_", sizeof (*item)); - - item->next = NULL; - item->expr = expr; - item->token = ffelex_token_use (expr_token); - *ffestd_expr_list_ = item; - ffestd_expr_list_ = &item->next; -} - -/* ffestd_R910_finish -- WRITE statement list complete - - ffestd_R910_finish(); - - Just wrap up any local activities. */ - -void -ffestd_R910_finish () -{ - ffestd_check_finish_ (); -} - -/* ffestd_R911_start -- PRINT statement list begin - - ffestd_R911_start(); - - Verify that PRINT is valid here, and begin accepting items in the - list. */ - -void -ffestd_R911_start (ffestvFormat format) -{ - ffestdStmt_ stmt; - - ffestd_check_start_ (); - - stmt = ffestd_stmt_new_ (FFESTD_stmtidR911_); - ffestd_stmt_append_ (stmt); - ffestd_subr_line_save_ (stmt); - stmt->u.R911.pool = ffesta_output_pool; - stmt->u.R911.params = ffestd_subr_copy_print_ (); - stmt->u.R911.format = format; - stmt->u.R911.list = NULL; - ffestd_expr_list_ = &stmt->u.R911.list; - ffesta_set_outpooldisp (FFESTA_pooldispPRESERVE); -} - -/* ffestd_R911_item -- PRINT statement i/o item - - ffestd_R911_item(expr,expr_token); - - Implement output-list expression. */ - -void -ffestd_R911_item (ffebld expr, ffelexToken expr_token) -{ - ffestdExprItem_ item; - - ffestd_check_item_ (); - - item = (ffestdExprItem_) malloc_new_kp (ffesta_output_pool, - "ffestdExprItem_", sizeof (*item)); - - item->next = NULL; - item->expr = expr; - item->token = ffelex_token_use (expr_token); - *ffestd_expr_list_ = item; - ffestd_expr_list_ = &item->next; -} - -/* ffestd_R911_finish -- PRINT statement list complete - - ffestd_R911_finish(); - - Just wrap up any local activities. */ - -void -ffestd_R911_finish () -{ - ffestd_check_finish_ (); -} - -/* ffestd_R919 -- BACKSPACE statement - - ffestd_R919(); - - Make sure a BACKSPACE is valid in the current context, and implement it. */ - -void -ffestd_R919 () -{ - ffestdStmt_ stmt; - - ffestd_check_simple_ (); - - stmt = ffestd_stmt_new_ (FFESTD_stmtidR919_); - ffestd_stmt_append_ (stmt); - ffestd_subr_line_save_ (stmt); - stmt->u.R919.pool = ffesta_output_pool; - stmt->u.R919.params = ffestd_subr_copy_beru_ (); - ffesta_set_outpooldisp (FFESTA_pooldispPRESERVE); -} - -/* ffestd_R920 -- ENDFILE statement - - ffestd_R920(); - - Make sure a ENDFILE is valid in the current context, and implement it. */ - -void -ffestd_R920 () -{ - ffestdStmt_ stmt; - - ffestd_check_simple_ (); - - stmt = ffestd_stmt_new_ (FFESTD_stmtidR920_); - ffestd_stmt_append_ (stmt); - ffestd_subr_line_save_ (stmt); - stmt->u.R920.pool = ffesta_output_pool; - stmt->u.R920.params = ffestd_subr_copy_beru_ (); - ffesta_set_outpooldisp (FFESTA_pooldispPRESERVE); -} - -/* ffestd_R921 -- REWIND statement - - ffestd_R921(); - - Make sure a REWIND is valid in the current context, and implement it. */ - -void -ffestd_R921 () -{ - ffestdStmt_ stmt; - - ffestd_check_simple_ (); - - stmt = ffestd_stmt_new_ (FFESTD_stmtidR921_); - ffestd_stmt_append_ (stmt); - ffestd_subr_line_save_ (stmt); - stmt->u.R921.pool = ffesta_output_pool; - stmt->u.R921.params = ffestd_subr_copy_beru_ (); - ffesta_set_outpooldisp (FFESTA_pooldispPRESERVE); -} - -/* ffestd_R923A -- INQUIRE statement (non-IOLENGTH version) - - ffestd_R923A(bool by_file); - - Make sure an INQUIRE is valid in the current context, and implement it. */ - -void -ffestd_R923A (bool by_file) -{ - ffestdStmt_ stmt; - - ffestd_check_simple_ (); - -#define specified(something) \ - (ffestp_file.inquire.inquire_spec[something].kw_or_val_present) - - /* Warn if there are any thing we don't handle via f2c libraries. */ - if (specified (FFESTP_inquireixACTION) - || specified (FFESTP_inquireixCARRIAGECONTROL) - || specified (FFESTP_inquireixDEFAULTFILE) - || specified (FFESTP_inquireixDELIM) - || specified (FFESTP_inquireixKEYED) - || specified (FFESTP_inquireixORGANIZATION) - || specified (FFESTP_inquireixPAD) - || specified (FFESTP_inquireixPOSITION) - || specified (FFESTP_inquireixREAD) - || specified (FFESTP_inquireixREADWRITE) - || specified (FFESTP_inquireixRECORDTYPE) - || specified (FFESTP_inquireixWRITE)) - { - ffebad_start (FFEBAD_INQUIRE_UNSUPPORTED); - ffebad_here (0, ffelex_token_where_line (ffesta_tokens[0]), - ffelex_token_where_column (ffesta_tokens[0])); - ffebad_finish (); - } - -#undef specified - - stmt = ffestd_stmt_new_ (FFESTD_stmtidR923A_); - ffestd_stmt_append_ (stmt); - ffestd_subr_line_save_ (stmt); - stmt->u.R923A.pool = ffesta_output_pool; - stmt->u.R923A.params = ffestd_subr_copy_inquire_ (); - stmt->u.R923A.by_file = by_file; - ffesta_set_outpooldisp (FFESTA_pooldispPRESERVE); -} - -/* ffestd_R923B_start -- INQUIRE(IOLENGTH=expr) statement list begin - - ffestd_R923B_start(); - - Verify that INQUIRE is valid here, and begin accepting items in the - list. */ - -void -ffestd_R923B_start () -{ - ffestdStmt_ stmt; - - ffestd_check_start_ (); - - stmt = ffestd_stmt_new_ (FFESTD_stmtidR923B_); - ffestd_stmt_append_ (stmt); - ffestd_subr_line_save_ (stmt); - stmt->u.R923B.pool = ffesta_output_pool; - stmt->u.R923B.params = ffestd_subr_copy_inquire_ (); - stmt->u.R923B.list = NULL; - ffestd_expr_list_ = &stmt->u.R923B.list; - ffesta_set_outpooldisp (FFESTA_pooldispPRESERVE); -} - -/* ffestd_R923B_item -- INQUIRE statement i/o item - - ffestd_R923B_item(expr,expr_token); - - Implement output-list expression. */ - -void -ffestd_R923B_item (ffebld expr) -{ - ffestdExprItem_ item; - - ffestd_check_item_ (); - - item = (ffestdExprItem_) malloc_new_kp (ffesta_output_pool, - "ffestdExprItem_", sizeof (*item)); - - item->next = NULL; - item->expr = expr; - *ffestd_expr_list_ = item; - ffestd_expr_list_ = &item->next; -} - -/* ffestd_R923B_finish -- INQUIRE statement list complete - - ffestd_R923B_finish(); - - Just wrap up any local activities. */ - -void -ffestd_R923B_finish () -{ - ffestd_check_finish_ (); -} - -/* ffestd_R1001 -- FORMAT statement - - ffestd_R1001(format_list); */ - -void -ffestd_R1001 (ffesttFormatList f) -{ - ffestsHolder str; - ffests s = &str; - ffestdStmt_ stmt; - - ffestd_check_simple_ (); - - if (ffestd_label_formatdef_ == NULL) - return; /* Nothing to hook it up to (no label def). */ - - ffests_new (s, malloc_pool_image (), 80); - ffests_putc (s, '('); - ffestd_R1001dump_ (s, f); /* Build the string in s. */ - ffests_putc (s, ')'); - - stmt = ffestd_stmt_new_ (FFESTD_stmtidR1001_); - ffestd_stmt_append_ (stmt); - stmt->u.R1001.str = str; - - ffestd_label_formatdef_ = NULL; -} - -/* ffestd_R1001dump_ -- Dump list of formats - - ffesttFormatList list; - ffestd_R1001dump_(list,0); - - The formats in the list are dumped. */ - -static void -ffestd_R1001dump_ (ffests s, ffesttFormatList list) -{ - ffesttFormatList next; - - for (next = list->next; next != list; next = next->next) - { - if (next != list->next) - ffests_putc (s, ','); - switch (next->type) - { - case FFESTP_formattypeI: - ffestd_R1001dump_1005_3_ (s, next, "I"); - break; - - case FFESTP_formattypeB: - ffestd_R1001error_ (next); - break; - - case FFESTP_formattypeO: - ffestd_R1001dump_1005_3_ (s, next, "O"); - break; - - case FFESTP_formattypeZ: - ffestd_R1001dump_1005_3_ (s, next, "Z"); - break; - - case FFESTP_formattypeF: - ffestd_R1001dump_1005_4_ (s, next, "F"); - break; - - case FFESTP_formattypeE: - ffestd_R1001dump_1005_5_ (s, next, "E"); - break; - - case FFESTP_formattypeEN: - ffestd_R1001error_ (next); - break; - - case FFESTP_formattypeG: - ffestd_R1001dump_1005_5_ (s, next, "G"); - break; - - case FFESTP_formattypeL: - ffestd_R1001dump_1005_2_ (s, next, "L"); - break; - - case FFESTP_formattypeA: - ffestd_R1001dump_1005_1_ (s, next, "A"); - break; - - case FFESTP_formattypeD: - ffestd_R1001dump_1005_4_ (s, next, "D"); - break; - - case FFESTP_formattypeQ: - ffestd_R1001error_ (next); - break; - - case FFESTP_formattypeDOLLAR: - ffestd_R1001dump_1010_1_ (s, next, "$"); - break; - - case FFESTP_formattypeP: - ffestd_R1001dump_1010_4_ (s, next, "P"); - break; - - case FFESTP_formattypeT: - ffestd_R1001dump_1010_5_ (s, next, "T"); - break; - - case FFESTP_formattypeTL: - ffestd_R1001dump_1010_5_ (s, next, "TL"); - break; - - case FFESTP_formattypeTR: - ffestd_R1001dump_1010_5_ (s, next, "TR"); - break; - - case FFESTP_formattypeX: - ffestd_R1001dump_1010_2_ (s, next, "X"); - break; - - case FFESTP_formattypeS: - ffestd_R1001dump_1010_1_ (s, next, "S"); - break; - - case FFESTP_formattypeSP: - ffestd_R1001dump_1010_1_ (s, next, "SP"); - break; - - case FFESTP_formattypeSS: - ffestd_R1001dump_1010_1_ (s, next, "SS"); - break; - - case FFESTP_formattypeBN: - ffestd_R1001dump_1010_1_ (s, next, "BN"); - break; - - case FFESTP_formattypeBZ: - ffestd_R1001dump_1010_1_ (s, next, "BZ"); - break; - - case FFESTP_formattypeSLASH: - ffestd_R1001dump_1010_2_ (s, next, "/"); - break; - - case FFESTP_formattypeCOLON: - ffestd_R1001dump_1010_1_ (s, next, ":"); - break; - - case FFESTP_formattypeR1016: - switch (ffelex_token_type (next->t)) - { - case FFELEX_typeCHARACTER: - { - char *p = ffelex_token_text (next->t); - ffeTokenLength i = ffelex_token_length (next->t); - - ffests_putc (s, '\002'); - while (i-- != 0) - { - if (*p == '\002') - ffests_putc (s, '\002'); - ffests_putc (s, *p); - ++p; - } - ffests_putc (s, '\002'); - } - break; - - case FFELEX_typeHOLLERITH: - { - char *p = ffelex_token_text (next->t); - ffeTokenLength i = ffelex_token_length (next->t); - - ffests_printf (s, "%" ffeTokenLength_f "uH", i); - while (i-- != 0) - { - ffests_putc (s, *p); - ++p; - } - } - break; - - default: - assert (FALSE); - } - break; - - case FFESTP_formattypeFORMAT: - if (next->u.R1003D.R1004.present) - { - if (next->u.R1003D.R1004.rtexpr) - ffestd_R1001rtexpr_ (s, next, next->u.R1003D.R1004.u.expr); - else - ffests_printf (s, "%lu", next->u.R1003D.R1004.u.unsigned_val); - } - - ffests_putc (s, '('); - ffestd_R1001dump_ (s, next->u.R1003D.format); - ffests_putc (s, ')'); - break; - - default: - assert (FALSE); - } - } -} - -/* ffestd_R1001dump_1005_1_ -- Dump a particular format - - ffesttFormatList f; - ffestd_R1001dump_1005_1_(f,"I"); - - The format is dumped with form [r]X[w]. */ - -static void -ffestd_R1001dump_1005_1_ (ffests s, ffesttFormatList f, const char *string) -{ - assert (!f->u.R1005.R1007_or_R1008.present); - assert (!f->u.R1005.R1009.present); - - if (f->u.R1005.R1004.present) - { - if (f->u.R1005.R1004.rtexpr) - ffestd_R1001rtexpr_ (s, f, f->u.R1005.R1004.u.expr); - else - ffests_printf (s, "%lu", f->u.R1005.R1004.u.unsigned_val); - } - - ffests_puts (s, string); - - if (f->u.R1005.R1006.present) - { - if (f->u.R1005.R1006.rtexpr) - ffestd_R1001rtexpr_ (s, f, f->u.R1005.R1006.u.expr); - else - ffests_printf (s, "%lu", f->u.R1005.R1006.u.unsigned_val); - } -} - -/* ffestd_R1001dump_1005_2_ -- Dump a particular format - - ffesttFormatList f; - ffestd_R1001dump_1005_2_(f,"I"); - - The format is dumped with form [r]Xw. */ - -static void -ffestd_R1001dump_1005_2_ (ffests s, ffesttFormatList f, const char *string) -{ - assert (!f->u.R1005.R1007_or_R1008.present); - assert (!f->u.R1005.R1009.present); - assert (f->u.R1005.R1006.present); - - if (f->u.R1005.R1004.present) - { - if (f->u.R1005.R1004.rtexpr) - ffestd_R1001rtexpr_ (s, f, f->u.R1005.R1004.u.expr); - else - ffests_printf (s, "%lu", f->u.R1005.R1004.u.unsigned_val); - } - - ffests_puts (s, string); - - if (f->u.R1005.R1006.rtexpr) - ffestd_R1001rtexpr_ (s, f, f->u.R1005.R1006.u.expr); - else - ffests_printf (s, "%lu", f->u.R1005.R1006.u.unsigned_val); -} - -/* ffestd_R1001dump_1005_3_ -- Dump a particular format - - ffesttFormatList f; - ffestd_R1001dump_1005_3_(f,"I"); - - The format is dumped with form [r]Xw[.m]. */ - -static void -ffestd_R1001dump_1005_3_ (ffests s, ffesttFormatList f, const char *string) -{ - assert (!f->u.R1005.R1009.present); - assert (f->u.R1005.R1006.present); - - if (f->u.R1005.R1004.present) - { - if (f->u.R1005.R1004.rtexpr) - ffestd_R1001rtexpr_ (s, f, f->u.R1005.R1004.u.expr); - else - ffests_printf (s, "%lu", f->u.R1005.R1004.u.unsigned_val); - } - - ffests_puts (s, string); - - if (f->u.R1005.R1006.rtexpr) - ffestd_R1001rtexpr_ (s, f, f->u.R1005.R1006.u.expr); - else - ffests_printf (s, "%lu", f->u.R1005.R1006.u.unsigned_val); - - if (f->u.R1005.R1007_or_R1008.present) - { - ffests_putc (s, '.'); - if (f->u.R1005.R1007_or_R1008.rtexpr) - ffestd_R1001rtexpr_ (s, f, f->u.R1005.R1007_or_R1008.u.expr); - else - ffests_printf (s, "%lu", f->u.R1005.R1007_or_R1008.u.unsigned_val); - } -} - -/* ffestd_R1001dump_1005_4_ -- Dump a particular format - - ffesttFormatList f; - ffestd_R1001dump_1005_4_(f,"I"); - - The format is dumped with form [r]Xw.d. */ - -static void -ffestd_R1001dump_1005_4_ (ffests s, ffesttFormatList f, const char *string) -{ - assert (!f->u.R1005.R1009.present); - assert (f->u.R1005.R1007_or_R1008.present); - assert (f->u.R1005.R1006.present); - - if (f->u.R1005.R1004.present) - { - if (f->u.R1005.R1004.rtexpr) - ffestd_R1001rtexpr_ (s, f, f->u.R1005.R1004.u.expr); - else - ffests_printf (s, "%lu", f->u.R1005.R1004.u.unsigned_val); - } - - ffests_puts (s, string); - - if (f->u.R1005.R1006.rtexpr) - ffestd_R1001rtexpr_ (s, f, f->u.R1005.R1006.u.expr); - else - ffests_printf (s, "%lu", f->u.R1005.R1006.u.unsigned_val); - - ffests_putc (s, '.'); - if (f->u.R1005.R1007_or_R1008.rtexpr) - ffestd_R1001rtexpr_ (s, f, f->u.R1005.R1007_or_R1008.u.expr); - else - ffests_printf (s, "%lu", f->u.R1005.R1007_or_R1008.u.unsigned_val); -} - -/* ffestd_R1001dump_1005_5_ -- Dump a particular format - - ffesttFormatList f; - ffestd_R1001dump_1005_5_(f,"I"); - - The format is dumped with form [r]Xw.d[Ee]. */ - -static void -ffestd_R1001dump_1005_5_ (ffests s, ffesttFormatList f, const char *string) -{ - assert (f->u.R1005.R1007_or_R1008.present); - assert (f->u.R1005.R1006.present); - - if (f->u.R1005.R1004.present) - { - if (f->u.R1005.R1004.rtexpr) - ffestd_R1001rtexpr_ (s, f, f->u.R1005.R1004.u.expr); - else - ffests_printf (s, "%lu", f->u.R1005.R1004.u.unsigned_val); - } - - ffests_puts (s, string); - - if (f->u.R1005.R1006.rtexpr) - ffestd_R1001rtexpr_ (s, f, f->u.R1005.R1006.u.expr); - else - ffests_printf (s, "%lu", f->u.R1005.R1006.u.unsigned_val); - - ffests_putc (s, '.'); - if (f->u.R1005.R1007_or_R1008.rtexpr) - ffestd_R1001rtexpr_ (s, f, f->u.R1005.R1007_or_R1008.u.expr); - else - ffests_printf (s, "%lu", f->u.R1005.R1007_or_R1008.u.unsigned_val); - - if (f->u.R1005.R1009.present) - { - ffests_putc (s, 'E'); - if (f->u.R1005.R1009.rtexpr) - ffestd_R1001rtexpr_ (s, f, f->u.R1005.R1009.u.expr); - else - ffests_printf (s, "%lu", f->u.R1005.R1009.u.unsigned_val); - } -} - -/* ffestd_R1001dump_1010_1_ -- Dump a particular format - - ffesttFormatList f; - ffestd_R1001dump_1010_1_(f,"I"); - - The format is dumped with form X. */ - -static void -ffestd_R1001dump_1010_1_ (ffests s, ffesttFormatList f, const char *string) -{ - assert (!f->u.R1010.val.present); - - ffests_puts (s, string); -} - -/* ffestd_R1001dump_1010_2_ -- Dump a particular format - - ffesttFormatList f; - ffestd_R1001dump_1010_2_(f,"I"); - - The format is dumped with form [r]X. */ - -static void -ffestd_R1001dump_1010_2_ (ffests s, ffesttFormatList f, const char *string) -{ - if (f->u.R1010.val.present) - { - if (f->u.R1010.val.rtexpr) - ffestd_R1001rtexpr_ (s, f, f->u.R1010.val.u.expr); - else - ffests_printf (s, "%lu", f->u.R1010.val.u.unsigned_val); - } - - ffests_puts (s, string); -} - -/* ffestd_R1001dump_1010_4_ -- Dump a particular format - - ffesttFormatList f; - ffestd_R1001dump_1010_4_(f,"I"); - - The format is dumped with form kX. Note that k is signed. */ - -static void -ffestd_R1001dump_1010_4_ (ffests s, ffesttFormatList f, const char *string) -{ - assert (f->u.R1010.val.present); - - if (f->u.R1010.val.rtexpr) - ffestd_R1001rtexpr_ (s, f, f->u.R1010.val.u.expr); - else - ffests_printf (s, "%ld", f->u.R1010.val.u.signed_val); - - ffests_puts (s, string); -} - -/* ffestd_R1001dump_1010_5_ -- Dump a particular format - - ffesttFormatList f; - ffestd_R1001dump_1010_5_(f,"I"); - - The format is dumped with form Xn. */ - -static void -ffestd_R1001dump_1010_5_ (ffests s, ffesttFormatList f, const char *string) -{ - assert (f->u.R1010.val.present); - - ffests_puts (s, string); - - if (f->u.R1010.val.rtexpr) - ffestd_R1001rtexpr_ (s, f, f->u.R1010.val.u.expr); - else - ffests_printf (s, "%lu", f->u.R1010.val.u.unsigned_val); -} - -/* ffestd_R1001error_ -- Complain about FORMAT specification not supported - - ffesttFormatList f; - ffestd_R1001error_(f); - - An error message is produced. */ - -static void -ffestd_R1001error_ (ffesttFormatList f) -{ - ffebad_start (FFEBAD_FORMAT_UNSUPPORTED); - ffebad_here (0, ffelex_token_where_line (f->t), ffelex_token_where_column (f->t)); - ffebad_finish (); -} - -static void -ffestd_R1001rtexpr_ (ffests s, ffesttFormatList f, ffebld expr) -{ - if ((expr == NULL) - || (ffebld_op (expr) != FFEBLD_opCONTER) - || (ffeinfo_basictype (ffebld_info (expr)) != FFEINFO_basictypeINTEGER) - || (ffeinfo_kindtype (ffebld_info (expr)) == FFEINFO_kindtypeINTEGER4)) - { - ffebad_start (FFEBAD_FORMAT_VARIABLE); - ffebad_here (0, ffelex_token_where_line (f->t), ffelex_token_where_column (f->t)); - ffebad_finish (); - } - else - { - int val; - - switch (ffeinfo_kindtype (ffebld_info (expr))) - { -#if FFETARGET_okINTEGER1 - case FFEINFO_kindtypeINTEGER1: - val = ffebld_constant_integer1 (ffebld_conter (expr)); - break; -#endif - -#if FFETARGET_okINTEGER2 - case FFEINFO_kindtypeINTEGER2: - val = ffebld_constant_integer2 (ffebld_conter (expr)); - break; -#endif - -#if FFETARGET_okINTEGER3 - case FFEINFO_kindtypeINTEGER3: - val = ffebld_constant_integer3 (ffebld_conter (expr)); - break; -#endif - - default: - assert ("bad INTEGER constant kind type" == NULL); - /* Fall through. */ - case FFEINFO_kindtypeANY: - return; - } - ffests_printf (s, "%ld", (long) val); - } -} - -/* ffestd_R1102 -- PROGRAM statement - - ffestd_R1102(name_token); - - Make sure ffestd_kind_ identifies an empty block. Make sure name_token - gives a valid name. Implement the beginning of a main program. */ - -void -ffestd_R1102 (ffesymbol s, ffelexToken name UNUSED) -{ - ffestd_check_simple_ (); - - assert (ffestd_block_level_ == 0); - ffestd_is_reachable_ = TRUE; - - ffecom_notify_primary_entry (s); - ffe_set_is_mainprog (TRUE); /* Is a main program. */ - ffe_set_is_saveall (TRUE); /* Main program always has implicit SAVE. */ - - ffestw_set_sym (ffestw_stack_top (), s); -} - -/* ffestd_R1103 -- End a PROGRAM - - ffestd_R1103(); */ - -void -ffestd_R1103 (bool ok UNUSED) -{ - ffestdStmt_ stmt; - - assert (ffestd_block_level_ == 0); - - if (FFESTD_IS_END_OPTIMIZED_ && ffestd_is_reachable_) - ffestd_R842 (NULL); /* Generate STOP. */ - - if (ffestw_state (ffestw_stack_top ()) != FFESTV_statePROGRAM5) - ffestd_subr_labels_ (FALSE);/* Handle any undefined labels. */ - - stmt = ffestd_stmt_new_ (FFESTD_stmtidR1103_); - ffestd_stmt_append_ (stmt); -} - -/* ffestd_R1105 -- MODULE statement - - ffestd_R1105(name_token); - - Make sure ffestd_kind_ identifies an empty block. Make sure name_token - gives a valid name. Implement the beginning of a module. */ - -#if FFESTR_F90 -void -ffestd_R1105 (ffelexToken name) -{ - assert (ffestd_block_level_ == 0); - - ffestd_check_simple_ (); - - ffestd_subr_f90_ (); - return; - -#ifdef FFESTD_F90 - fprintf (dmpout, "* MODULE %s\n", ffelex_token_text (name)); -#endif -} - -/* ffestd_R1106 -- End a MODULE - - ffestd_R1106(TRUE); */ - -void -ffestd_R1106 (bool ok) -{ - assert (ffestd_block_level_ == 0); - - /* Generate any wrap-up code here (unlikely in MODULE!). */ - - if (ffestw_state (ffestw_stack_top ()) != FFESTV_stateMODULE5) - ffestd_subr_labels_ (TRUE); /* Handle any undefined labels (unlikely). */ - - return; /* F90. */ - -#ifdef FFESTD_F90 - fprintf (dmpout, "< END_MODULE %s\n", - ffelex_token_text (ffestw_name (ffestw_stack_top ()))); -#endif -} - -/* ffestd_R1107_start -- USE statement list begin - - ffestd_R1107_start(); - - Verify that USE is valid here, and begin accepting items in the list. */ - -void -ffestd_R1107_start (ffelexToken name, bool only) -{ - ffestd_check_start_ (); - - ffestd_subr_f90_ (); - return; - -#ifdef FFESTD_F90 - fprintf (dmpout, "* USE %s,", ffelex_token_text (name)); /* NB - _shriek_begin_uses_. */ - if (only) - fputs ("only: ", dmpout); -#endif -} - -/* ffestd_R1107_item -- USE statement for name - - ffestd_R1107_item(local_token,use_token); - - Make sure name_token identifies a valid object to be USEed. local_token - may be NULL if _start_ was called with only==TRUE. */ - -void -ffestd_R1107_item (ffelexToken local, ffelexToken use) -{ - ffestd_check_item_ (); - assert (use != NULL); - - return; /* F90. */ - -#ifdef FFESTD_F90 - if (local != NULL) - fprintf (dmpout, "%s=>", ffelex_token_text (local)); - fprintf (dmpout, "%s,", ffelex_token_text (use)); -#endif -} - -/* ffestd_R1107_finish -- USE statement list complete - - ffestd_R1107_finish(); - - Just wrap up any local activities. */ - -void -ffestd_R1107_finish () -{ - ffestd_check_finish_ (); - - return; /* F90. */ - -#ifdef FFESTD_F90 - fputc ('\n', dmpout); -#endif -} - -#endif -/* ffestd_R1111 -- BLOCK DATA statement - - ffestd_R1111(name_token); - - Make sure ffestd_kind_ identifies no current program unit. If not - NULL, make sure name_token gives a valid name. Implement the beginning - of a block data program unit. */ - -void -ffestd_R1111 (ffesymbol s, ffelexToken name UNUSED) -{ - assert (ffestd_block_level_ == 0); - ffestd_is_reachable_ = TRUE; - - ffestd_check_simple_ (); - - ffecom_notify_primary_entry (s); - ffestw_set_sym (ffestw_stack_top (), s); -} - -/* ffestd_R1112 -- End a BLOCK DATA - - ffestd_R1112(TRUE); */ - -void -ffestd_R1112 (bool ok UNUSED) -{ - ffestdStmt_ stmt; - - assert (ffestd_block_level_ == 0); - - /* Generate any return-like code here (not likely for BLOCK DATA!). */ - - if (ffestw_state (ffestw_stack_top ()) != FFESTV_stateBLOCKDATA5) - ffestd_subr_labels_ (TRUE); /* Handle any undefined labels. */ - - stmt = ffestd_stmt_new_ (FFESTD_stmtidR1112_); - ffestd_stmt_append_ (stmt); -} - -/* ffestd_R1202 -- INTERFACE statement - - ffestd_R1202(operator,defined_name); - - Make sure ffestd_kind_ identifies an INTERFACE block. - Implement the end of the current interface. - - 06-Jun-90 JCB 1.1 - Allow no operator or name to mean INTERFACE by itself; missed this - valid form when originally doing syntactic analysis code. */ - -#if FFESTR_F90 -void -ffestd_R1202 (ffestpDefinedOperator operator, ffelexToken name) -{ - ffestd_check_simple_ (); - - ffestd_subr_f90_ (); - return; - -#ifdef FFESTD_F90 - switch (operator) - { - case FFESTP_definedoperatorNone: - if (name == NULL) - fputs ("* INTERFACE_unnamed\n", dmpout); - else - fprintf (dmpout, "* INTERFACE %s\n", ffelex_token_text (name)); - break; - - case FFESTP_definedoperatorOPERATOR: - fprintf (dmpout, "* INTERFACE_OPERATOR (.%s.)\n", ffelex_token_text (name)); - break; - - case FFESTP_definedoperatorASSIGNMENT: - fputs ("* INTERFACE_ASSIGNMENT (=)\n", dmpout); - break; - - case FFESTP_definedoperatorPOWER: - fputs ("* INTERFACE_OPERATOR (**)\n", dmpout); - break; + ffesttFormatList next; - case FFESTP_definedoperatorMULT: - fputs ("* INTERFACE_OPERATOR (*)\n", dmpout); - break; + for (next = list->next; next != list; next = next->next) + { + if (next != list->next) + ffests_putc (s, ','); + switch (next->type) + { + case FFESTP_formattypeI: + ffestd_R1001dump_1005_3_ (s, next, "I"); + break; - case FFESTP_definedoperatorADD: - fputs ("* INTERFACE_OPERATOR (+)\n", dmpout); - break; + case FFESTP_formattypeB: + ffestd_R1001error_ (next); + break; - case FFESTP_definedoperatorCONCAT: - fputs ("* INTERFACE_OPERATOR (//)\n", dmpout); - break; + case FFESTP_formattypeO: + ffestd_R1001dump_1005_3_ (s, next, "O"); + break; - case FFESTP_definedoperatorDIVIDE: - fputs ("* INTERFACE_OPERATOR (/)\n", dmpout); - break; + case FFESTP_formattypeZ: + ffestd_R1001dump_1005_3_ (s, next, "Z"); + break; - case FFESTP_definedoperatorSUBTRACT: - fputs ("* INTERFACE_OPERATOR (-)\n", dmpout); - break; + case FFESTP_formattypeF: + ffestd_R1001dump_1005_4_ (s, next, "F"); + break; - case FFESTP_definedoperatorNOT: - fputs ("* INTERFACE_OPERATOR (.not.)\n", dmpout); - break; + case FFESTP_formattypeE: + ffestd_R1001dump_1005_5_ (s, next, "E"); + break; - case FFESTP_definedoperatorAND: - fputs ("* INTERFACE_OPERATOR (.and.)\n", dmpout); - break; + case FFESTP_formattypeEN: + ffestd_R1001error_ (next); + break; - case FFESTP_definedoperatorOR: - fputs ("* INTERFACE_OPERATOR (.or.)\n", dmpout); - break; + case FFESTP_formattypeG: + ffestd_R1001dump_1005_5_ (s, next, "G"); + break; - case FFESTP_definedoperatorEQV: - fputs ("* INTERFACE_OPERATOR (.eqv.)\n", dmpout); - break; + case FFESTP_formattypeL: + ffestd_R1001dump_1005_2_ (s, next, "L"); + break; - case FFESTP_definedoperatorNEQV: - fputs ("* INTERFACE_OPERATOR (.neqv.)\n", dmpout); - break; + case FFESTP_formattypeA: + ffestd_R1001dump_1005_1_ (s, next, "A"); + break; - case FFESTP_definedoperatorEQ: - fputs ("* INTERFACE_OPERATOR (==)\n", dmpout); - break; + case FFESTP_formattypeD: + ffestd_R1001dump_1005_4_ (s, next, "D"); + break; - case FFESTP_definedoperatorNE: - fputs ("* INTERFACE_OPERATOR (/=)\n", dmpout); - break; + case FFESTP_formattypeQ: + ffestd_R1001error_ (next); + break; - case FFESTP_definedoperatorLT: - fputs ("* INTERFACE_OPERATOR (<)\n", dmpout); - break; + case FFESTP_formattypeDOLLAR: + ffestd_R1001dump_1010_1_ (s, next, "$"); + break; - case FFESTP_definedoperatorLE: - fputs ("* INTERFACE_OPERATOR (<=)\n", dmpout); - break; + case FFESTP_formattypeP: + ffestd_R1001dump_1010_4_ (s, next, "P"); + break; - case FFESTP_definedoperatorGT: - fputs ("* INTERFACE_OPERATOR (>)\n", dmpout); - break; + case FFESTP_formattypeT: + ffestd_R1001dump_1010_5_ (s, next, "T"); + break; - case FFESTP_definedoperatorGE: - fputs ("* INTERFACE_OPERATOR (>=)\n", dmpout); - break; + case FFESTP_formattypeTL: + ffestd_R1001dump_1010_5_ (s, next, "TL"); + break; - default: - assert (FALSE); - break; - } -#endif -} + case FFESTP_formattypeTR: + ffestd_R1001dump_1010_5_ (s, next, "TR"); + break; -/* ffestd_R1203 -- End an INTERFACE + case FFESTP_formattypeX: + ffestd_R1001dump_1010_2_ (s, next, "X"); + break; - ffestd_R1203(TRUE); */ + case FFESTP_formattypeS: + ffestd_R1001dump_1010_1_ (s, next, "S"); + break; -void -ffestd_R1203 (bool ok) -{ - return; /* F90. */ + case FFESTP_formattypeSP: + ffestd_R1001dump_1010_1_ (s, next, "SP"); + break; -#ifdef FFESTD_F90 - fputs ("* END_INTERFACE\n", dmpout); -#endif -} + case FFESTP_formattypeSS: + ffestd_R1001dump_1010_1_ (s, next, "SS"); + break; -/* ffestd_R1205_start -- MODULE PROCEDURE statement list begin + case FFESTP_formattypeBN: + ffestd_R1001dump_1010_1_ (s, next, "BN"); + break; - ffestd_R1205_start(); + case FFESTP_formattypeBZ: + ffestd_R1001dump_1010_1_ (s, next, "BZ"); + break; - Verify that MODULE PROCEDURE is valid here, and begin accepting items in - the list. */ + case FFESTP_formattypeSLASH: + ffestd_R1001dump_1010_2_ (s, next, "/"); + break; -void -ffestd_R1205_start () -{ - ffestd_check_start_ (); + case FFESTP_formattypeCOLON: + ffestd_R1001dump_1010_1_ (s, next, ":"); + break; - return; /* F90. */ + case FFESTP_formattypeR1016: + switch (ffelex_token_type (next->t)) + { + case FFELEX_typeCHARACTER: + { + char *p = ffelex_token_text (next->t); + ffeTokenLength i = ffelex_token_length (next->t); -#ifdef FFESTD_F90 - fputs ("* MODULE_PROCEDURE ", dmpout); -#endif -} + ffests_putc (s, '\002'); + while (i-- != 0) + { + if (*p == '\002') + ffests_putc (s, '\002'); + ffests_putc (s, *p); + ++p; + } + ffests_putc (s, '\002'); + } + break; -/* ffestd_R1205_item -- MODULE PROCEDURE statement for name + case FFELEX_typeHOLLERITH: + { + char *p = ffelex_token_text (next->t); + ffeTokenLength i = ffelex_token_length (next->t); - ffestd_R1205_item(name_token); + ffests_printf (s, "%" ffeTokenLength_f "uH", i); + while (i-- != 0) + { + ffests_putc (s, *p); + ++p; + } + } + break; - Make sure name_token identifies a valid object to be MODULE PROCEDUREed. */ + default: + assert (FALSE); + } + break; -void -ffestd_R1205_item (ffelexToken name) -{ - ffestd_check_item_ (); - assert (name != NULL); + case FFESTP_formattypeFORMAT: + if (next->u.R1003D.R1004.present) + { + if (next->u.R1003D.R1004.rtexpr) + ffestd_R1001rtexpr_ (s, next, next->u.R1003D.R1004.u.expr); + else + ffests_printf (s, "%lu", next->u.R1003D.R1004.u.unsigned_val); + } - return; /* F90. */ + ffests_putc (s, '('); + ffestd_R1001dump_ (s, next->u.R1003D.format); + ffests_putc (s, ')'); + break; -#ifdef FFESTD_F90 - fprintf (dmpout, "%s,", ffelex_token_text (name)); -#endif + default: + assert (FALSE); + } + } } -/* ffestd_R1205_finish -- MODULE PROCEDURE statement list complete +/* ffestd_R1001dump_1005_1_ -- Dump a particular format - ffestd_R1205_finish(); + ffesttFormatList f; + ffestd_R1001dump_1005_1_(f,"I"); - Just wrap up any local activities. */ + The format is dumped with form [r]X[w]. */ -void -ffestd_R1205_finish () +static void +ffestd_R1001dump_1005_1_ (ffests s, ffesttFormatList f, const char *string) { - ffestd_check_finish_ (); + assert (!f->u.R1005.R1007_or_R1008.present); + assert (!f->u.R1005.R1009.present); + + if (f->u.R1005.R1004.present) + { + if (f->u.R1005.R1004.rtexpr) + ffestd_R1001rtexpr_ (s, f, f->u.R1005.R1004.u.expr); + else + ffests_printf (s, "%lu", f->u.R1005.R1004.u.unsigned_val); + } - return; /* F90. */ + ffests_puts (s, string); -#ifdef FFESTD_F90 - fputc ('\n', dmpout); -#endif + if (f->u.R1005.R1006.present) + { + if (f->u.R1005.R1006.rtexpr) + ffestd_R1001rtexpr_ (s, f, f->u.R1005.R1006.u.expr); + else + ffests_printf (s, "%lu", f->u.R1005.R1006.u.unsigned_val); + } } -#endif -/* ffestd_R1207_start -- EXTERNAL statement list begin +/* ffestd_R1001dump_1005_2_ -- Dump a particular format - ffestd_R1207_start(); + ffesttFormatList f; + ffestd_R1001dump_1005_2_(f,"I"); - Verify that EXTERNAL is valid here, and begin accepting items in the list. */ + The format is dumped with form [r]Xw. */ -void -ffestd_R1207_start () +static void +ffestd_R1001dump_1005_2_ (ffests s, ffesttFormatList f, const char *string) { - ffestd_check_start_ (); -} - -/* ffestd_R1207_item -- EXTERNAL statement for name + assert (!f->u.R1005.R1007_or_R1008.present); + assert (!f->u.R1005.R1009.present); + assert (f->u.R1005.R1006.present); - ffestd_R1207_item(name_token); + if (f->u.R1005.R1004.present) + { + if (f->u.R1005.R1004.rtexpr) + ffestd_R1001rtexpr_ (s, f, f->u.R1005.R1004.u.expr); + else + ffests_printf (s, "%lu", f->u.R1005.R1004.u.unsigned_val); + } - Make sure name_token identifies a valid object to be EXTERNALd. */ + ffests_puts (s, string); -void -ffestd_R1207_item (ffelexToken name) -{ - ffestd_check_item_ (); - assert (name != NULL); + if (f->u.R1005.R1006.rtexpr) + ffestd_R1001rtexpr_ (s, f, f->u.R1005.R1006.u.expr); + else + ffests_printf (s, "%lu", f->u.R1005.R1006.u.unsigned_val); } -/* ffestd_R1207_finish -- EXTERNAL statement list complete +/* ffestd_R1001dump_1005_3_ -- Dump a particular format - ffestd_R1207_finish(); + ffesttFormatList f; + ffestd_R1001dump_1005_3_(f,"I"); - Just wrap up any local activities. */ + The format is dumped with form [r]Xw[.m]. */ -void -ffestd_R1207_finish () +static void +ffestd_R1001dump_1005_3_ (ffests s, ffesttFormatList f, const char *string) { - ffestd_check_finish_ (); -} + assert (!f->u.R1005.R1009.present); + assert (f->u.R1005.R1006.present); -/* ffestd_R1208_start -- INTRINSIC statement list begin + if (f->u.R1005.R1004.present) + { + if (f->u.R1005.R1004.rtexpr) + ffestd_R1001rtexpr_ (s, f, f->u.R1005.R1004.u.expr); + else + ffests_printf (s, "%lu", f->u.R1005.R1004.u.unsigned_val); + } - ffestd_R1208_start(); + ffests_puts (s, string); - Verify that INTRINSIC is valid here, and begin accepting items in the list. */ + if (f->u.R1005.R1006.rtexpr) + ffestd_R1001rtexpr_ (s, f, f->u.R1005.R1006.u.expr); + else + ffests_printf (s, "%lu", f->u.R1005.R1006.u.unsigned_val); -void -ffestd_R1208_start () -{ - ffestd_check_start_ (); + if (f->u.R1005.R1007_or_R1008.present) + { + ffests_putc (s, '.'); + if (f->u.R1005.R1007_or_R1008.rtexpr) + ffestd_R1001rtexpr_ (s, f, f->u.R1005.R1007_or_R1008.u.expr); + else + ffests_printf (s, "%lu", f->u.R1005.R1007_or_R1008.u.unsigned_val); + } } -/* ffestd_R1208_item -- INTRINSIC statement for name +/* ffestd_R1001dump_1005_4_ -- Dump a particular format - ffestd_R1208_item(name_token); + ffesttFormatList f; + ffestd_R1001dump_1005_4_(f,"I"); - Make sure name_token identifies a valid object to be INTRINSICd. */ + The format is dumped with form [r]Xw.d. */ -void -ffestd_R1208_item (ffelexToken name) +static void +ffestd_R1001dump_1005_4_ (ffests s, ffesttFormatList f, const char *string) { - ffestd_check_item_ (); - assert (name != NULL); -} + assert (!f->u.R1005.R1009.present); + assert (f->u.R1005.R1007_or_R1008.present); + assert (f->u.R1005.R1006.present); -/* ffestd_R1208_finish -- INTRINSIC statement list complete + if (f->u.R1005.R1004.present) + { + if (f->u.R1005.R1004.rtexpr) + ffestd_R1001rtexpr_ (s, f, f->u.R1005.R1004.u.expr); + else + ffests_printf (s, "%lu", f->u.R1005.R1004.u.unsigned_val); + } - ffestd_R1208_finish(); + ffests_puts (s, string); - Just wrap up any local activities. */ + if (f->u.R1005.R1006.rtexpr) + ffestd_R1001rtexpr_ (s, f, f->u.R1005.R1006.u.expr); + else + ffests_printf (s, "%lu", f->u.R1005.R1006.u.unsigned_val); -void -ffestd_R1208_finish () -{ - ffestd_check_finish_ (); + ffests_putc (s, '.'); + if (f->u.R1005.R1007_or_R1008.rtexpr) + ffestd_R1001rtexpr_ (s, f, f->u.R1005.R1007_or_R1008.u.expr); + else + ffests_printf (s, "%lu", f->u.R1005.R1007_or_R1008.u.unsigned_val); } -/* ffestd_R1212 -- CALL statement +/* ffestd_R1001dump_1005_5_ -- Dump a particular format - ffestd_R1212(expr,expr_token); + ffesttFormatList f; + ffestd_R1001dump_1005_5_(f,"I"); - Make sure statement is valid here; implement. */ + The format is dumped with form [r]Xw.d[Ee]. */ -void -ffestd_R1212 (ffebld expr) +static void +ffestd_R1001dump_1005_5_ (ffests s, ffesttFormatList f, const char *string) { - ffestdStmt_ stmt; - - ffestd_check_simple_ (); - - stmt = ffestd_stmt_new_ (FFESTD_stmtidR1212_); - ffestd_stmt_append_ (stmt); - ffestd_subr_line_save_ (stmt); - stmt->u.R1212.pool = ffesta_output_pool; - stmt->u.R1212.expr = expr; - ffesta_set_outpooldisp (FFESTA_pooldispPRESERVE); -} + assert (f->u.R1005.R1007_or_R1008.present); + assert (f->u.R1005.R1006.present); -/* ffestd_R1213 -- Defined assignment statement + if (f->u.R1005.R1004.present) + { + if (f->u.R1005.R1004.rtexpr) + ffestd_R1001rtexpr_ (s, f, f->u.R1005.R1004.u.expr); + else + ffests_printf (s, "%lu", f->u.R1005.R1004.u.unsigned_val); + } - ffestd_R1213(dest_expr,source_expr,source_token); + ffests_puts (s, string); - Make sure the assignment is valid. */ + if (f->u.R1005.R1006.rtexpr) + ffestd_R1001rtexpr_ (s, f, f->u.R1005.R1006.u.expr); + else + ffests_printf (s, "%lu", f->u.R1005.R1006.u.unsigned_val); -#if FFESTR_F90 -void -ffestd_R1213 (ffebld dest, ffebld source) -{ - ffestd_check_simple_ (); + ffests_putc (s, '.'); + if (f->u.R1005.R1007_or_R1008.rtexpr) + ffestd_R1001rtexpr_ (s, f, f->u.R1005.R1007_or_R1008.u.expr); + else + ffests_printf (s, "%lu", f->u.R1005.R1007_or_R1008.u.unsigned_val); - ffestd_subr_f90_ (); + if (f->u.R1005.R1009.present) + { + ffests_putc (s, 'E'); + if (f->u.R1005.R1009.rtexpr) + ffestd_R1001rtexpr_ (s, f, f->u.R1005.R1009.u.expr); + else + ffests_printf (s, "%lu", f->u.R1005.R1009.u.unsigned_val); + } } -#endif -/* ffestd_R1219 -- FUNCTION statement - - ffestd_R1219(funcname,arglist,ending_token,kind,kindt,len,lent, - recursive); +/* ffestd_R1001dump_1010_1_ -- Dump a particular format - Make sure statement is valid here, register arguments for the - function name, and so on. + ffesttFormatList f; + ffestd_R1001dump_1010_1_(f,"I"); - 06-Jun-90 JCB 2.0 - Added the kind, len, and recursive arguments. */ + The format is dumped with form X. */ -void -ffestd_R1219 (ffesymbol s, ffelexToken funcname UNUSED, - ffesttTokenList args UNUSED, ffestpType type UNUSED, - ffebld kind UNUSED, ffelexToken kindt UNUSED, - ffebld len UNUSED, ffelexToken lent UNUSED, - bool recursive UNUSED, ffelexToken result UNUSED, - bool separate_result UNUSED) +static void +ffestd_R1001dump_1010_1_ (ffests s, ffesttFormatList f, const char *string) { - assert (ffestd_block_level_ == 0); - ffestd_is_reachable_ = TRUE; - - ffestd_check_simple_ (); + assert (!f->u.R1010.val.present); - ffecom_notify_primary_entry (s); - ffestw_set_sym (ffestw_stack_top (), s); + ffests_puts (s, string); } -/* ffestd_R1221 -- End a FUNCTION - - ffestd_R1221(TRUE); */ - -void -ffestd_R1221 (bool ok UNUSED) -{ - ffestdStmt_ stmt; +/* ffestd_R1001dump_1010_2_ -- Dump a particular format - assert (ffestd_block_level_ == 0); + ffesttFormatList f; + ffestd_R1001dump_1010_2_(f,"I"); - if (FFESTD_IS_END_OPTIMIZED_ && ffestd_is_reachable_) - ffestd_R1227 (NULL); /* Generate RETURN. */ + The format is dumped with form [r]X. */ - if (ffestw_state (ffestw_stack_top ()) != FFESTV_stateFUNCTION5) - ffestd_subr_labels_ (FALSE);/* Handle any undefined labels. */ +static void +ffestd_R1001dump_1010_2_ (ffests s, ffesttFormatList f, const char *string) +{ + if (f->u.R1010.val.present) + { + if (f->u.R1010.val.rtexpr) + ffestd_R1001rtexpr_ (s, f, f->u.R1010.val.u.expr); + else + ffests_printf (s, "%lu", f->u.R1010.val.u.unsigned_val); + } - stmt = ffestd_stmt_new_ (FFESTD_stmtidR1221_); - ffestd_stmt_append_ (stmt); + ffests_puts (s, string); } -/* ffestd_R1223 -- SUBROUTINE statement - - ffestd_R1223(subrname,arglist,ending_token,recursive_token); +/* ffestd_R1001dump_1010_4_ -- Dump a particular format - Make sure statement is valid here, register arguments for the - subroutine name, and so on. + ffesttFormatList f; + ffestd_R1001dump_1010_4_(f,"I"); - 06-Jun-90 JCB 2.0 - Added the recursive argument. */ + The format is dumped with form kX. Note that k is signed. */ -void -ffestd_R1223 (ffesymbol s, ffelexToken subrname UNUSED, - ffesttTokenList args UNUSED, ffelexToken final UNUSED, - bool recursive UNUSED) +static void +ffestd_R1001dump_1010_4_ (ffests s, ffesttFormatList f, const char *string) { - assert (ffestd_block_level_ == 0); - ffestd_is_reachable_ = TRUE; + assert (f->u.R1010.val.present); - ffestd_check_simple_ (); + if (f->u.R1010.val.rtexpr) + ffestd_R1001rtexpr_ (s, f, f->u.R1010.val.u.expr); + else + ffests_printf (s, "%ld", f->u.R1010.val.u.signed_val); - ffecom_notify_primary_entry (s); - ffestw_set_sym (ffestw_stack_top (), s); + ffests_puts (s, string); } -/* ffestd_R1225 -- End a SUBROUTINE - - ffestd_R1225(TRUE); */ +/* ffestd_R1001dump_1010_5_ -- Dump a particular format -void -ffestd_R1225 (bool ok UNUSED) -{ - ffestdStmt_ stmt; + ffesttFormatList f; + ffestd_R1001dump_1010_5_(f,"I"); - assert (ffestd_block_level_ == 0); + The format is dumped with form Xn. */ - if (FFESTD_IS_END_OPTIMIZED_ && ffestd_is_reachable_) - ffestd_R1227 (NULL); /* Generate RETURN. */ +static void +ffestd_R1001dump_1010_5_ (ffests s, ffesttFormatList f, const char *string) +{ + assert (f->u.R1010.val.present); - if (ffestw_state (ffestw_stack_top ()) != FFESTV_stateSUBROUTINE5) - ffestd_subr_labels_ (FALSE);/* Handle any undefined labels. */ + ffests_puts (s, string); - stmt = ffestd_stmt_new_ (FFESTD_stmtidR1225_); - ffestd_stmt_append_ (stmt); + if (f->u.R1010.val.rtexpr) + ffestd_R1001rtexpr_ (s, f, f->u.R1010.val.u.expr); + else + ffests_printf (s, "%lu", f->u.R1010.val.u.unsigned_val); } -/* ffestd_R1226 -- ENTRY statement +/* ffestd_R1001error_ -- Complain about FORMAT specification not supported - ffestd_R1226(entryname,arglist,ending_token); + ffesttFormatList f; + ffestd_R1001error_(f); - Make sure we're in a SUBROUTINE or FUNCTION, register arguments for the - entry point name, and so on. */ + An error message is produced. */ -void -ffestd_R1226 (ffesymbol entry) +static void +ffestd_R1001error_ (ffesttFormatList f) { - ffestd_check_simple_ (); + ffebad_start (FFEBAD_FORMAT_UNSUPPORTED); + ffebad_here (0, ffelex_token_where_line (f->t), ffelex_token_where_column (f->t)); + ffebad_finish (); +} - if (!ffesta_seen_first_exec || ffecom_2pass_advise_entrypoint (entry)) +static void +ffestd_R1001rtexpr_ (ffests s, ffesttFormatList f, ffebld expr) +{ + if ((expr == NULL) + || (ffebld_op (expr) != FFEBLD_opCONTER) + || (ffeinfo_basictype (ffebld_info (expr)) != FFEINFO_basictypeINTEGER) + || (ffeinfo_kindtype (ffebld_info (expr)) == FFEINFO_kindtypeINTEGER4)) { - ffestdStmt_ stmt; + ffebad_start (FFEBAD_FORMAT_VARIABLE); + ffebad_here (0, ffelex_token_where_line (f->t), ffelex_token_where_column (f->t)); + ffebad_finish (); + } + else + { + int val; + + switch (ffeinfo_kindtype (ffebld_info (expr))) + { +#if FFETARGET_okINTEGER1 + case FFEINFO_kindtypeINTEGER1: + val = ffebld_constant_integer1 (ffebld_conter (expr)); + break; +#endif + +#if FFETARGET_okINTEGER2 + case FFEINFO_kindtypeINTEGER2: + val = ffebld_constant_integer2 (ffebld_conter (expr)); + break; +#endif + +#if FFETARGET_okINTEGER3 + case FFEINFO_kindtypeINTEGER3: + val = ffebld_constant_integer3 (ffebld_conter (expr)); + break; +#endif - stmt = ffestd_stmt_new_ (FFESTD_stmtidR1226_); - ffestd_stmt_append_ (stmt); - ffestd_subr_line_save_ (stmt); - stmt->u.R1226.entry = entry; - stmt->u.R1226.entrynum = ++ffestd_2pass_entrypoints_; + default: + assert ("bad INTEGER constant kind type" == NULL); + /* Fall through. */ + case FFEINFO_kindtypeANY: + return; + } + ffests_printf (s, "%ld", (long) val); } - - ffestd_is_reachable_ = TRUE; } -/* ffestd_R1227 -- RETURN statement +/* ffestd_R1102 -- PROGRAM statement - ffestd_R1227(expr); + ffestd_R1102(name_token); - Make sure statement is valid here; implement. expr and expr_token are - both NULL if there was no expression. */ + Make sure ffestd_kind_ identifies an empty block. Make sure name_token + gives a valid name. Implement the beginning of a main program. */ void -ffestd_R1227 (ffebld expr) +ffestd_R1102 (ffesymbol s, ffelexToken name UNUSED) { - ffestdStmt_ stmt; - ffestd_check_simple_ (); - stmt = ffestd_stmt_new_ (FFESTD_stmtidR1227_); - ffestd_stmt_append_ (stmt); - ffestd_subr_line_save_ (stmt); - stmt->u.R1227.pool = ffesta_output_pool; - stmt->u.R1227.block = ffestw_stack_top (); - stmt->u.R1227.expr = expr; - ffesta_set_outpooldisp (FFESTA_pooldispPRESERVE); + assert (ffestd_block_level_ == 0); + ffestd_is_reachable_ = TRUE; - if (ffestd_block_level_ == 0) - ffestd_is_reachable_ = FALSE; + ffecom_notify_primary_entry (s); + ffe_set_is_mainprog (TRUE); /* Is a main program. */ + ffe_set_is_saveall (TRUE); /* Main program always has implicit SAVE. */ + + ffestw_set_sym (ffestw_stack_top (), s); } -/* ffestd_R1228 -- CONTAINS statement +/* ffestd_R1103 -- End a PROGRAM - ffestd_R1228(); */ + ffestd_R1103(); */ -#if FFESTR_F90 void -ffestd_R1228 () +ffestd_R1103 (bool ok UNUSED) { - assert (ffestd_block_level_ == 0); - - ffestd_check_simple_ (); + ffestdStmt_ stmt; - /* Generate RETURN/STOP code here */ + assert (ffestd_block_level_ == 0); - ffestd_subr_labels_ (ffestw_state (ffestw_stack_top ()) - == FFESTV_stateMODULE5); /* Handle any undefined - labels. */ + if (FFESTD_IS_END_OPTIMIZED_ && ffestd_is_reachable_) + ffestd_R842 (NULL); /* Generate STOP. */ - ffestd_subr_f90_ (); - return; + if (ffestw_state (ffestw_stack_top ()) != FFESTV_statePROGRAM5) + ffestd_subr_labels_ (FALSE);/* Handle any undefined labels. */ -#ifdef FFESTD_F90 - fputs ("- CONTAINS\n", dmpout); -#endif + stmt = ffestd_stmt_new_ (FFESTD_stmtidR1103_); + ffestd_stmt_append_ (stmt); } -#endif -/* ffestd_R1229_start -- STMTFUNCTION statement begin - - ffestd_R1229_start(func_name,func_arg_list,close_paren); +/* ffestd_R1111 -- BLOCK DATA statement - This function does not really need to do anything, since _finish_ - gets all the info needed, and ffestc_R1229_start has already - done all the stuff that makes a two-phase operation (start and - finish) for handling statement functions necessary. + ffestd_R1111(name_token); - 03-Jan-91 JCB 2.0 - Do nothing, now that _finish_ does everything. */ + Make sure ffestd_kind_ identifies no current program unit. If not + NULL, make sure name_token gives a valid name. Implement the beginning + of a block data program unit. */ void -ffestd_R1229_start (ffelexToken name UNUSED, ffesttTokenList args UNUSED) +ffestd_R1111 (ffesymbol s, ffelexToken name UNUSED) { - ffestd_check_start_ (); -} - -/* ffestd_R1229_finish -- STMTFUNCTION statement list complete + assert (ffestd_block_level_ == 0); + ffestd_is_reachable_ = TRUE; - ffestd_R1229_finish(s); + ffestd_check_simple_ (); - The statement function's symbol is passed. Its list of dummy args is - accessed via ffesymbol_dummyargs and its expansion expression (expr) - is accessed via ffesymbol_sfexpr. + ffecom_notify_primary_entry (s); + ffestw_set_sym (ffestw_stack_top (), s); +} - If sfexpr is NULL, an error occurred parsing the expansion expression, so - just cancel the effects of ffestd_R1229_start and pretend nothing - happened. Otherwise, install the expression as the expansion for the - statement function, then clean up. +/* ffestd_R1112 -- End a BLOCK DATA - 03-Jan-91 JCB 2.0 - Takes sfunc sym instead of just the expansion expression as an - argument, so this function can do all the work, and _start_ is just - a nicety than can do nothing in a back end. */ + ffestd_R1112(TRUE); */ void -ffestd_R1229_finish (ffesymbol s) +ffestd_R1112 (bool ok UNUSED) { - ffebld expr = ffesymbol_sfexpr (s); - - ffestd_check_finish_ (); - - if (expr == NULL) - return; /* Nothing to do, definition didn't work. */ - - /* With gcc, cannot do anything here, because the backend hasn't even - (necessarily) been notified that we're compiling a program unit! */ - ffesta_set_outpooldisp (FFESTA_pooldispPRESERVE); -} - -/* ffestd_S3P4 -- INCLUDE line - - ffestd_S3P4(filename,filename_token); + ffestdStmt_ stmt; - Make sure INCLUDE not preceded by any semicolons or a label def; implement. */ + assert (ffestd_block_level_ == 0); -void -ffestd_S3P4 (ffebld filename) -{ - FILE *fi; - ffetargetCharacterDefault buildname; - ffewhereFile wf; + /* Generate any return-like code here (not likely for BLOCK DATA!). */ - ffestd_check_simple_ (); + if (ffestw_state (ffestw_stack_top ()) != FFESTV_stateBLOCKDATA5) + ffestd_subr_labels_ (TRUE); /* Handle any undefined labels. */ - assert (filename != NULL); - if (ffebld_op (filename) != FFEBLD_opANY) - { - assert (ffebld_op (filename) == FFEBLD_opCONTER); - assert (ffeinfo_basictype (ffebld_info (filename)) - == FFEINFO_basictypeCHARACTER); - assert (ffeinfo_kindtype (ffebld_info (filename)) - == FFEINFO_kindtypeCHARACTERDEFAULT); - buildname = ffebld_constant_characterdefault (ffebld_conter (filename)); - wf = ffewhere_file_new (ffetarget_text_characterdefault (buildname), - ffetarget_length_characterdefault (buildname)); - fi = ffecom_open_include (ffewhere_file_name (wf), - ffelex_token_where_line (ffesta_tokens[0]), - ffelex_token_where_column (ffesta_tokens[0])); - if (fi != NULL) - ffelex_set_include (wf, (ffelex_token_type (ffesta_tokens[0]) - == FFELEX_typeNAME), fi); - } + stmt = ffestd_stmt_new_ (FFESTD_stmtidR1112_); + ffestd_stmt_append_ (stmt); } -/* ffestd_V003_start -- STRUCTURE statement list begin +/* ffestd_R1207_start -- EXTERNAL statement list begin - ffestd_V003_start(structure_name); + ffestd_R1207_start(); - Verify that STRUCTURE is valid here, and begin accepting items in the list. */ + Verify that EXTERNAL is valid here, and begin accepting items in the list. */ -#if FFESTR_VXT void -ffestd_V003_start (ffelexToken structure_name) +ffestd_R1207_start () { ffestd_check_start_ (); - ffestd_subr_vxt_ (); } -/* ffestd_V003_item -- STRUCTURE statement for object-name +/* ffestd_R1207_item -- EXTERNAL statement for name - ffestd_V003_item(name_token,dim_list); + ffestd_R1207_item(name_token); - Make sure name_token identifies a valid object to be STRUCTUREd. */ + Make sure name_token identifies a valid object to be EXTERNALd. */ void -ffestd_V003_item (ffelexToken name, ffesttDimList dims) +ffestd_R1207_item (ffelexToken name) { ffestd_check_item_ (); + assert (name != NULL); } -/* ffestd_V003_finish -- STRUCTURE statement list complete +/* ffestd_R1207_finish -- EXTERNAL statement list complete - ffestd_V003_finish(); + ffestd_R1207_finish(); Just wrap up any local activities. */ void -ffestd_V003_finish () +ffestd_R1207_finish () { ffestd_check_finish_ (); } -/* ffestd_V004 -- End a STRUCTURE - - ffestd_V004(TRUE); */ - -void -ffestd_V004 (bool ok) -{ -} +/* ffestd_R1208_start -- INTRINSIC statement list begin -/* ffestd_V009 -- UNION statement + ffestd_R1208_start(); - ffestd_V009(); */ + Verify that INTRINSIC is valid here, and begin accepting items in the list. */ void -ffestd_V009 () +ffestd_R1208_start () { - ffestd_check_simple_ (); + ffestd_check_start_ (); } -/* ffestd_V010 -- End a UNION - - ffestd_V010(TRUE); */ - -void -ffestd_V010 (bool ok) -{ -} +/* ffestd_R1208_item -- INTRINSIC statement for name -/* ffestd_V012 -- MAP statement + ffestd_R1208_item(name_token); - ffestd_V012(); */ + Make sure name_token identifies a valid object to be INTRINSICd. */ void -ffestd_V012 () +ffestd_R1208_item (ffelexToken name) { - ffestd_check_simple_ (); + ffestd_check_item_ (); + assert (name != NULL); } -/* ffestd_V013 -- End a MAP +/* ffestd_R1208_finish -- INTRINSIC statement list complete + + ffestd_R1208_finish(); - ffestd_V013(TRUE); */ + Just wrap up any local activities. */ void -ffestd_V013 (bool ok) +ffestd_R1208_finish () { + ffestd_check_finish_ (); } -#endif -/* ffestd_V014_start -- VOLATILE statement list begin +/* ffestd_R1212 -- CALL statement - ffestd_V014_start(); + ffestd_R1212(expr,expr_token); - Verify that VOLATILE is valid here, and begin accepting items in the list. */ + Make sure statement is valid here; implement. */ void -ffestd_V014_start () +ffestd_R1212 (ffebld expr) { - ffestd_check_start_ (); -} - -/* ffestd_V014_item_object -- VOLATILE statement for object-name - - ffestd_V014_item_object(name_token); + ffestdStmt_ stmt; - Make sure name_token identifies a valid object to be VOLATILEd. */ + ffestd_check_simple_ (); -void -ffestd_V014_item_object (ffelexToken name UNUSED) -{ - ffestd_check_item_ (); + stmt = ffestd_stmt_new_ (FFESTD_stmtidR1212_); + ffestd_stmt_append_ (stmt); + ffestd_subr_line_save_ (stmt); + stmt->u.R1212.pool = ffesta_output_pool; + stmt->u.R1212.expr = expr; + ffesta_set_outpooldisp (FFESTA_pooldispPRESERVE); } -/* ffestd_V014_item_cblock -- VOLATILE statement for common-block-name +/* ffestd_R1219 -- FUNCTION statement - ffestd_V014_item_cblock(name_token); + ffestd_R1219(funcname,arglist,ending_token,kind,kindt,len,lent, + recursive); - Make sure name_token identifies a valid common block to be VOLATILEd. */ + Make sure statement is valid here, register arguments for the + function name, and so on. + + 06-Jun-90 JCB 2.0 + Added the kind, len, and recursive arguments. */ void -ffestd_V014_item_cblock (ffelexToken name UNUSED) +ffestd_R1219 (ffesymbol s, ffelexToken funcname UNUSED, + ffesttTokenList args UNUSED, ffestpType type UNUSED, + ffebld kind UNUSED, ffelexToken kindt UNUSED, + ffebld len UNUSED, ffelexToken lent UNUSED, + bool recursive UNUSED, ffelexToken result UNUSED, + bool separate_result UNUSED) { - ffestd_check_item_ (); -} - -/* ffestd_V014_finish -- VOLATILE statement list complete - - ffestd_V014_finish(); + assert (ffestd_block_level_ == 0); + ffestd_is_reachable_ = TRUE; - Just wrap up any local activities. */ + ffestd_check_simple_ (); -void -ffestd_V014_finish () -{ - ffestd_check_finish_ (); + ffecom_notify_primary_entry (s); + ffestw_set_sym (ffestw_stack_top (), s); } -/* ffestd_V016_start -- RECORD statement list begin - - ffestd_V016_start(); +/* ffestd_R1221 -- End a FUNCTION - Verify that RECORD is valid here, and begin accepting items in the list. */ + ffestd_R1221(TRUE); */ -#if FFESTR_VXT void -ffestd_V016_start () +ffestd_R1221 (bool ok UNUSED) { - ffestd_check_start_ (); -} + ffestdStmt_ stmt; -/* ffestd_V016_item_structure -- RECORD statement for common-block-name + assert (ffestd_block_level_ == 0); - ffestd_V016_item_structure(name_token); + if (FFESTD_IS_END_OPTIMIZED_ && ffestd_is_reachable_) + ffestd_R1227 (NULL); /* Generate RETURN. */ - Make sure name_token identifies a valid structure to be RECORDed. */ + if (ffestw_state (ffestw_stack_top ()) != FFESTV_stateFUNCTION5) + ffestd_subr_labels_ (FALSE);/* Handle any undefined labels. */ -void -ffestd_V016_item_structure (ffelexToken name) -{ - ffestd_check_item_ (); + stmt = ffestd_stmt_new_ (FFESTD_stmtidR1221_); + ffestd_stmt_append_ (stmt); } -/* ffestd_V016_item_object -- RECORD statement for object-name +/* ffestd_R1223 -- SUBROUTINE statement + + ffestd_R1223(subrname,arglist,ending_token,recursive_token); - ffestd_V016_item_object(name_token,dim_list); + Make sure statement is valid here, register arguments for the + subroutine name, and so on. - Make sure name_token identifies a valid object to be RECORDd. */ + 06-Jun-90 JCB 2.0 + Added the recursive argument. */ void -ffestd_V016_item_object (ffelexToken name, ffesttDimList dims) +ffestd_R1223 (ffesymbol s, ffelexToken subrname UNUSED, + ffesttTokenList args UNUSED, ffelexToken final UNUSED, + bool recursive UNUSED) { - ffestd_check_item_ (); -} - -/* ffestd_V016_finish -- RECORD statement list complete - - ffestd_V016_finish(); + assert (ffestd_block_level_ == 0); + ffestd_is_reachable_ = TRUE; - Just wrap up any local activities. */ + ffestd_check_simple_ (); -void -ffestd_V016_finish () -{ - ffestd_check_finish_ (); + ffecom_notify_primary_entry (s); + ffestw_set_sym (ffestw_stack_top (), s); } -/* ffestd_V018_start -- REWRITE(...) statement list begin - - ffestd_V018_start(); +/* ffestd_R1225 -- End a SUBROUTINE - Verify that REWRITE is valid here, and begin accepting items in the - list. */ + ffestd_R1225(TRUE); */ void -ffestd_V018_start (ffestvFormat format) +ffestd_R1225 (bool ok UNUSED) { - ffestd_check_start_ (); - ffestd_subr_vxt_ (); -} + ffestdStmt_ stmt; -/* ffestd_V018_item -- REWRITE statement i/o item + assert (ffestd_block_level_ == 0); - ffestd_V018_item(expr,expr_token); + if (FFESTD_IS_END_OPTIMIZED_ && ffestd_is_reachable_) + ffestd_R1227 (NULL); /* Generate RETURN. */ - Implement output-list expression. */ + if (ffestw_state (ffestw_stack_top ()) != FFESTV_stateSUBROUTINE5) + ffestd_subr_labels_ (FALSE);/* Handle any undefined labels. */ -void -ffestd_V018_item (ffebld expr) -{ - ffestd_check_item_ (); + stmt = ffestd_stmt_new_ (FFESTD_stmtidR1225_); + ffestd_stmt_append_ (stmt); } -/* ffestd_V018_finish -- REWRITE statement list complete +/* ffestd_R1226 -- ENTRY statement - ffestd_V018_finish(); + ffestd_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 -ffestd_V018_finish () +ffestd_R1226 (ffesymbol entry) { - ffestd_check_finish_ (); -} - -/* ffestd_V019_start -- ACCEPT statement list begin + ffestd_check_simple_ (); - ffestd_V019_start(); + if (!ffesta_seen_first_exec || ffecom_2pass_advise_entrypoint (entry)) + { + ffestdStmt_ stmt; - Verify that ACCEPT is valid here, and begin accepting items in the - list. */ + stmt = ffestd_stmt_new_ (FFESTD_stmtidR1226_); + ffestd_stmt_append_ (stmt); + ffestd_subr_line_save_ (stmt); + stmt->u.R1226.entry = entry; + stmt->u.R1226.entrynum = ++ffestd_2pass_entrypoints_; + } -void -ffestd_V019_start (ffestvFormat format) -{ - ffestd_check_start_ (); - ffestd_subr_vxt_ (); + ffestd_is_reachable_ = TRUE; } -/* ffestd_V019_item -- ACCEPT statement i/o item +/* ffestd_R1227 -- RETURN statement - ffestd_V019_item(expr,expr_token); + ffestd_R1227(expr); - Implement output-list expression. */ + Make sure statement is valid here; implement. expr and expr_token are + both NULL if there was no expression. */ void -ffestd_V019_item (ffebld expr) +ffestd_R1227 (ffebld expr) { - ffestd_check_item_ (); -} - -/* ffestd_V019_finish -- ACCEPT statement list complete + ffestdStmt_ stmt; - ffestd_V019_finish(); + ffestd_check_simple_ (); - Just wrap up any local activities. */ + stmt = ffestd_stmt_new_ (FFESTD_stmtidR1227_); + ffestd_stmt_append_ (stmt); + ffestd_subr_line_save_ (stmt); + stmt->u.R1227.pool = ffesta_output_pool; + stmt->u.R1227.block = ffestw_stack_top (); + stmt->u.R1227.expr = expr; + ffesta_set_outpooldisp (FFESTA_pooldispPRESERVE); -void -ffestd_V019_finish () -{ - ffestd_check_finish_ (); + if (ffestd_block_level_ == 0) + ffestd_is_reachable_ = FALSE; } -#endif -/* ffestd_V020_start -- TYPE statement list begin +/* ffestd_R1229_start -- STMTFUNCTION statement begin - ffestd_V020_start(); + ffestd_R1229_start(func_name,func_arg_list,close_paren); - Verify that TYPE is valid here, and begin accepting items in the - list. */ + This function does not really need to do anything, since _finish_ + gets all the info needed, and ffestc_R1229_start has already + done all the stuff that makes a two-phase operation (start and + finish) for handling statement functions necessary. + + 03-Jan-91 JCB 2.0 + Do nothing, now that _finish_ does everything. */ void -ffestd_V020_start (ffestvFormat format UNUSED) +ffestd_R1229_start (ffelexToken name UNUSED, ffesttTokenList args UNUSED) { ffestd_check_start_ (); - ffestd_subr_vxt_ (); } -/* ffestd_V020_item -- TYPE statement i/o item - - ffestd_V020_item(expr,expr_token); - - Implement output-list expression. */ +/* ffestd_R1229_finish -- STMTFUNCTION statement list complete -void -ffestd_V020_item (ffebld expr UNUSED) -{ - ffestd_check_item_ (); -} + ffestd_R1229_finish(s); -/* ffestd_V020_finish -- TYPE statement list complete + The statement function's symbol is passed. Its list of dummy args is + accessed via ffesymbol_dummyargs and its expansion expression (expr) + is accessed via ffesymbol_sfexpr. - ffestd_V020_finish(); + If sfexpr is NULL, an error occurred parsing the expansion expression, so + just cancel the effects of ffestd_R1229_start and pretend nothing + happened. Otherwise, install the expression as the expansion for the + statement function, then clean up. - Just wrap up any local activities. */ + 03-Jan-91 JCB 2.0 + Takes sfunc sym instead of just the expansion expression as an + argument, so this function can do all the work, and _start_ is just + a nicety than can do nothing in a back end. */ void -ffestd_V020_finish () +ffestd_R1229_finish (ffesymbol s) { - ffestd_check_finish_ (); -} - -/* ffestd_V021 -- DELETE statement + ffebld expr = ffesymbol_sfexpr (s); - ffestd_V021(); + ffestd_check_finish_ (); - Make sure a DELETE is valid in the current context, and implement it. */ + if (expr == NULL) + return; /* Nothing to do, definition didn't work. */ -#if FFESTR_VXT -void -ffestd_V021 () -{ - ffestd_check_simple_ (); - ffestd_subr_vxt_ (); + /* With gcc, cannot do anything here, because the backend hasn't even + (necessarily) been notified that we're compiling a program unit! */ + ffesta_set_outpooldisp (FFESTA_pooldispPRESERVE); } -/* ffestd_V022 -- UNLOCK statement +/* ffestd_S3P4 -- INCLUDE line - ffestd_V022(); + ffestd_S3P4(filename,filename_token); - Make sure a UNLOCK is valid in the current context, and implement it. */ + Make sure INCLUDE not preceded by any semicolons or a label def; implement. */ void -ffestd_V022 () +ffestd_S3P4 (ffebld filename) { + FILE *fi; + ffetargetCharacterDefault buildname; + ffewhereFile wf; + ffestd_check_simple_ (); - ffestd_subr_vxt_ (); + + assert (filename != NULL); + if (ffebld_op (filename) != FFEBLD_opANY) + { + assert (ffebld_op (filename) == FFEBLD_opCONTER); + assert (ffeinfo_basictype (ffebld_info (filename)) + == FFEINFO_basictypeCHARACTER); + assert (ffeinfo_kindtype (ffebld_info (filename)) + == FFEINFO_kindtypeCHARACTERDEFAULT); + buildname = ffebld_constant_characterdefault (ffebld_conter (filename)); + wf = ffewhere_file_new (ffetarget_text_characterdefault (buildname), + ffetarget_length_characterdefault (buildname)); + fi = ffecom_open_include (ffewhere_file_name (wf), + ffelex_token_where_line (ffesta_tokens[0]), + ffelex_token_where_column (ffesta_tokens[0])); + if (fi != NULL) + ffelex_set_include (wf, (ffelex_token_type (ffesta_tokens[0]) + == FFELEX_typeNAME), fi); + } } -/* ffestd_V023_start -- ENCODE(...) statement list begin +/* ffestd_V014_start -- VOLATILE statement list begin - ffestd_V023_start(); + ffestd_V014_start(); - Verify that ENCODE is valid here, and begin accepting items in the - list. */ + Verify that VOLATILE is valid here, and begin accepting items in the list. */ void -ffestd_V023_start () +ffestd_V014_start () { ffestd_check_start_ (); - ffestd_subr_vxt_ (); } -/* ffestd_V023_item -- ENCODE statement i/o item +/* ffestd_V014_item_object -- VOLATILE statement for object-name - ffestd_V023_item(expr,expr_token); + ffestd_V014_item_object(name_token); - Implement output-list expression. */ + Make sure name_token identifies a valid object to be VOLATILEd. */ void -ffestd_V023_item (ffebld expr) +ffestd_V014_item_object (ffelexToken name UNUSED) { ffestd_check_item_ (); } -/* ffestd_V023_finish -- ENCODE statement list complete - - ffestd_V023_finish(); - - Just wrap up any local activities. */ - -void -ffestd_V023_finish () -{ - ffestd_check_finish_ (); -} - -/* ffestd_V024_start -- DECODE(...) statement list begin - - ffestd_V024_start(); - - Verify that DECODE is valid here, and begin accepting items in the - list. */ - -void -ffestd_V024_start () -{ - ffestd_check_start_ (); - ffestd_subr_vxt_ (); -} - -/* ffestd_V024_item -- DECODE statement i/o item +/* ffestd_V014_item_cblock -- VOLATILE statement for common-block-name - ffestd_V024_item(expr,expr_token); + ffestd_V014_item_cblock(name_token); - Implement output-list expression. */ + Make sure name_token identifies a valid common block to be VOLATILEd. */ void -ffestd_V024_item (ffebld expr) +ffestd_V014_item_cblock (ffelexToken name UNUSED) { ffestd_check_item_ (); } -/* ffestd_V024_finish -- DECODE statement list complete +/* ffestd_V014_finish -- VOLATILE statement list complete - ffestd_V024_finish(); + ffestd_V014_finish(); Just wrap up any local activities. */ void -ffestd_V024_finish () +ffestd_V014_finish () { ffestd_check_finish_ (); } -/* ffestd_V025_start -- DEFINEFILE statement list begin +/* ffestd_V020_start -- TYPE statement list begin - ffestd_V025_start(); + ffestd_V020_start(); - Verify that DEFINEFILE is valid here, and begin accepting items in the + Verify that TYPE is valid here, and begin accepting items in the list. */ void -ffestd_V025_start () +ffestd_V020_start (ffestvFormat format UNUSED) { ffestd_check_start_ (); ffestd_subr_vxt_ (); } -/* ffestd_V025_item -- DEFINE FILE statement item +/* ffestd_V020_item -- TYPE statement i/o item - ffestd_V025_item(u,ut,m,mt,n,nt,asv,asvt); + ffestd_V020_item(expr,expr_token); - Implement item. Treat each item kind of like a separate statement, - since there's really no need to treat them as an aggregate. */ + Implement output-list expression. */ void -ffestd_V025_item (ffebld u, ffebld m, ffebld n, ffebld asv) +ffestd_V020_item (ffebld expr UNUSED) { ffestd_check_item_ (); } -/* ffestd_V025_finish -- DEFINE FILE statement list complete +/* ffestd_V020_finish -- TYPE statement list complete - ffestd_V025_finish(); + ffestd_V020_finish(); Just wrap up any local activities. */ void -ffestd_V025_finish () +ffestd_V020_finish () { ffestd_check_finish_ (); } -/* ffestd_V026 -- FIND statement - - ffestd_V026(); - - Make sure a FIND is valid in the current context, and implement it. */ - -void -ffestd_V026 () -{ - ffestd_check_simple_ (); - ffestd_subr_vxt_ (); -} - -#endif /* ffestd_V027_start -- VXT PARAMETER statement list begin ffestd_V027_start(); diff --git a/gcc/f/std.h b/gcc/f/std.h index ea8292c..29a82a8 100644 --- a/gcc/f/std.h +++ b/gcc/f/std.h @@ -1,5 +1,5 @@ /* std.h -- Private #include File (module.h template V1.0) - Copyright (C) 1995 Free Software Foundation, Inc. + Copyright (C) 1995, 2003 Free Software Foundation, Inc. Contributed by James Craig Burley. This file is part of GNU Fortran. @@ -58,10 +58,6 @@ the Free Software Foundation, 59 Temple Place - Suite 330, Boston, MA void ffestd_begin_uses (void); void ffestd_do (bool ok); -#if FFESTR_F90 -void ffestd_end_uses (bool ok); -void ffestd_end_R740 (bool ok); -#endif void ffestd_end_R807 (bool ok); void ffestd_exec_begin (void); void ffestd_exec_end (void); @@ -70,26 +66,6 @@ void ffestd_labeldef_any (ffelab label); void ffestd_labeldef_branch (ffelab label); void ffestd_labeldef_format (ffelab label); void ffestd_labeldef_useless (ffelab label); -#if FFESTR_F90 -void ffestd_R423A (void); -void ffestd_R423B (void); -void ffestd_R424 (ffelexToken access, ffestrOther access_kw, ffelexToken name); -void ffestd_R425 (bool ok); -void ffestd_R519_start (ffestrOther intent_kw); -void ffestd_R519_item (ffelexToken name); -void ffestd_R519_finish (void); -void ffestd_R520_start (void); -void ffestd_R520_item (ffelexToken name); -void ffestd_R520_finish (void); -void ffestd_R521A (void); -void ffestd_R521Astart (void); -void ffestd_R521Aitem (ffelexToken name); -void ffestd_R521Afinish (void); -void ffestd_R521B (void); -void ffestd_R521Bstart (void); -void ffestd_R521Bitem (ffelexToken name); -void ffestd_R521Bfinish (void); -#endif void ffestd_R522 (void); void ffestd_R522start (void); void ffestd_R522item_object (ffelexToken name); @@ -98,17 +74,6 @@ void ffestd_R522finish (void); void ffestd_R524_start (bool virtual); void ffestd_R524_item (ffelexToken name, ffesttDimList dims); void ffestd_R524_finish (void); -#if FFESTR_F90 -void ffestd_R525_start (void); -void ffestd_R525_item (ffelexToken name, ffesttDimList dims); -void ffestd_R525_finish (void); -void ffestd_R526_start (void); -void ffestd_R526_item (ffelexToken name, ffesttDimList dims); -void ffestd_R526_finish (void); -void ffestd_R527_start (void); -void ffestd_R527_item (ffelexToken name, ffesttDimList dims); -void ffestd_R527_finish (void); -#endif void ffestd_R537_start (void); void ffestd_R537_item (ffebld dest, ffebld source); void ffestd_R537_finish (void); @@ -128,20 +93,7 @@ void ffestd_R547_start (void); void ffestd_R547_item_object (ffelexToken name, ffesttDimList dims); void ffestd_R547_item_cblock (ffelexToken name); void ffestd_R547_finish (void); -#if FFESTR_F90 -void ffestd_R620 (ffesttExprList exprlist, ffebld stat); -void ffestd_R624 (ffesttExprList pointers); -void ffestd_R625 (ffesttExprList exprlist, ffebld stat); -#endif void ffestd_R737A (ffebld dest, ffebld source); -#if FFESTR_F90 -void ffestd_R737B (ffebld dest, ffebld source); -void ffestd_R738 (ffebld dest, ffebld source); -void ffestd_R740 (ffebld expr); -void ffestd_R742 (ffebld expr); -void ffestd_R744 (void); -void ffestd_R745 (bool ok); -#endif void ffestd_R803 (ffelexToken construct_name, ffebld expr); void ffestd_R804 (ffebld expr, ffelexToken name); void ffestd_R805 (ffelexToken name); @@ -188,22 +140,8 @@ void ffestd_R923B_finish (void); void ffestd_R1001 (ffesttFormatList f); void ffestd_R1102 (ffesymbol s, ffelexToken name); void ffestd_R1103 (bool ok); -#if FFESTR_F90 -void ffestd_R1105 (ffelexToken name); -void ffestd_R1106 (bool ok); -void ffestd_R1107_start (ffelexToken name, bool only); -void ffestd_R1107_item (ffelexToken local, ffelexToken use); -void ffestd_R1107_finish (void); -#endif void ffestd_R1111 (ffesymbol s, ffelexToken name); void ffestd_R1112 (bool ok); -#if FFESTR_F90 -void ffestd_R1202 (ffestpDefinedOperator operator, ffelexToken name); -void ffestd_R1203 (bool ok); -void ffestd_R1205_start (void); -void ffestd_R1205_item (ffelexToken name); -void ffestd_R1205_finish (void); -#endif void ffestd_R1207_start (void); void ffestd_R1207_item (ffelexToken name); void ffestd_R1207_finish (void); @@ -211,9 +149,6 @@ void ffestd_R1208_start (void); void ffestd_R1208_item (ffelexToken name); void ffestd_R1208_finish (void); void ffestd_R1212 (ffebld expr); -#if FFESTR_F90 -void ffestd_R1213 (ffebld dest, ffebld source); -#endif void ffestd_R1219 (ffesymbol s, ffelexToken funcname, ffesttTokenList args, ffestpType type, ffebld kind, ffelexToken kindt, ffebld len, ffelexToken lent, @@ -225,55 +160,16 @@ void ffestd_R1223 (ffesymbol s, ffelexToken subrname, ffesttTokenList args, void ffestd_R1225 (bool ok); void ffestd_R1226 (ffesymbol entry); void ffestd_R1227 (ffebld expr); -#if FFESTR_F90 -void ffestd_R1228 (void); -#endif void ffestd_R1229_start (ffelexToken name, ffesttTokenList args); void ffestd_R1229_finish (ffesymbol s); void ffestd_S3P4 (ffebld filename); -#if FFESTR_VXT -void ffestd_V003_start (ffelexToken structure_name); -void ffestd_V003_item (ffelexToken name, ffesttDimList dims); -void ffestd_V003_finish (void); -void ffestd_V004 (bool ok); -void ffestd_V009 (void); -void ffestd_V010 (bool ok); -void ffestd_V012 (void); -void ffestd_V013 (bool ok); -#endif void ffestd_V014_start (void); void ffestd_V014_item_object (ffelexToken name); void ffestd_V014_item_cblock (ffelexToken name); void ffestd_V014_finish (void); -#if FFESTR_VXT -void ffestd_V016_start (void); -void ffestd_V016_item_structure (ffelexToken name); -void ffestd_V016_item_object (ffelexToken name, ffesttDimList dims); -void ffestd_V016_finish (void); -void ffestd_V018_start (ffestvFormat format); -void ffestd_V018_item (ffebld expr); -void ffestd_V018_finish (void); -void ffestd_V019_start (ffestvFormat format); -void ffestd_V019_item (ffebld expr); -void ffestd_V019_finish (void); -#endif void ffestd_V020_start (ffestvFormat format); void ffestd_V020_item (ffebld expr); void ffestd_V020_finish (void); -#if FFESTR_VXT -void ffestd_V021 (void); -void ffestd_V022 (void); -void ffestd_V023_start (void); -void ffestd_V023_item (ffebld expr); -void ffestd_V023_finish (void); -void ffestd_V024_start (void); -void ffestd_V024_item (ffebld expr); -void ffestd_V024_finish (void); -void ffestd_V025_start (void); -void ffestd_V025_item (ffebld u, ffebld m, ffebld n, ffebld asv); -void ffestd_V025_finish (void); -void ffestd_V026 (void); -#endif void ffestd_V027_start (void); void ffestd_V027_item (ffelexToken dest_token, ffebld source); void ffestd_V027_finish (void); diff --git a/gcc/f/ste.c b/gcc/f/ste.c index b0d464a..66ee92c 100644 --- a/gcc/f/ste.c +++ b/gcc/f/ste.c @@ -4436,54 +4436,6 @@ ffeste_R1227 (ffestw block UNUSED, ffebld expr) /* REWRITE statement -- start. */ -#if FFESTR_VXT -void -ffeste_V018_start (ffestpRewriteStmt *info, ffestvFormat format) -{ - ffeste_check_start_ (); -} - -/* REWRITE statement -- I/O item. */ - -void -ffeste_V018_item (ffebld expr) -{ - ffeste_check_item_ (); -} - -/* REWRITE statement -- end. */ - -void -ffeste_V018_finish () -{ - ffeste_check_finish_ (); -} - -/* ACCEPT statement -- start. */ - -void -ffeste_V019_start (ffestpAcceptStmt *info, ffestvFormat format) -{ - ffeste_check_start_ (); -} - -/* ACCEPT statement -- I/O item. */ - -void -ffeste_V019_item (ffebld expr) -{ - ffeste_check_item_ (); -} - -/* ACCEPT statement -- end. */ - -void -ffeste_V019_finish () -{ - ffeste_check_finish_ (); -} - -#endif /* TYPE statement -- start. */ void @@ -4511,102 +4463,6 @@ ffeste_V020_finish () /* DELETE statement. */ -#if FFESTR_VXT -void -ffeste_V021 (ffestpDeleteStmt *info) -{ - ffeste_check_simple_ (); -} - -/* UNLOCK statement. */ - -void -ffeste_V022 (ffestpBeruStmt *info) -{ - ffeste_check_simple_ (); -} - -/* ENCODE statement -- start. */ - -void -ffeste_V023_start (ffestpVxtcodeStmt *info) -{ - ffeste_check_start_ (); -} - -/* ENCODE statement -- I/O item. */ - -void -ffeste_V023_item (ffebld expr) -{ - ffeste_check_item_ (); -} - -/* ENCODE statement -- end. */ - -void -ffeste_V023_finish () -{ - ffeste_check_finish_ (); -} - -/* DECODE statement -- start. */ - -void -ffeste_V024_start (ffestpVxtcodeStmt *info) -{ - ffeste_check_start_ (); -} - -/* DECODE statement -- I/O item. */ - -void -ffeste_V024_item (ffebld expr) -{ - ffeste_check_item_ (); -} - -/* DECODE statement -- end. */ - -void -ffeste_V024_finish () -{ - ffeste_check_finish_ (); -} - -/* DEFINEFILE statement -- start. */ - -void -ffeste_V025_start () -{ - ffeste_check_start_ (); -} - -/* DEFINE FILE statement -- item. */ - -void -ffeste_V025_item (ffebld u, ffebld m, ffebld n, ffebld asv) -{ - ffeste_check_item_ (); -} - -/* DEFINE FILE statement -- end. */ - -void -ffeste_V025_finish () -{ - ffeste_check_finish_ (); -} - -/* FIND statement. */ - -void -ffeste_V026 (ffestpFindStmt *info) -{ - ffeste_check_simple_ (); -} - -#endif #ifdef ENABLE_CHECKING void diff --git a/gcc/f/ste.h b/gcc/f/ste.h index d911105..ac04a4c 100644 --- a/gcc/f/ste.h +++ b/gcc/f/ste.h @@ -114,31 +114,9 @@ void ffeste_R1221 (void); void ffeste_R1225 (void); void ffeste_R1226 (ffesymbol entry); void ffeste_R1227 (ffestw block, ffebld expr); -#if FFESTR_VXT -void ffeste_V018_start (ffestpRewriteStmt *info, ffestvFormat format); -void ffeste_V018_item (ffebld expr); -void ffeste_V018_finish (void); -void ffeste_V019_start (ffestpAcceptStmt *info, ffestvFormat format); -void ffeste_V019_item (ffebld expr); -void ffeste_V019_finish (void); -#endif void ffeste_V020_start (ffestpTypeStmt *info, ffestvFormat format); void ffeste_V020_item (ffebld expr); void ffeste_V020_finish (void); -#if FFESTR_VXT -void ffeste_V021 (ffestpDeleteStmt *info); -void ffeste_V022 (ffestpBeruStmt *info); -void ffeste_V023_start (ffestpVxtcodeStmt *info); -void ffeste_V023_item (ffebld expr); -void ffeste_V023_finish (void); -void ffeste_V024_start (ffestpVxtcodeStmt *info); -void ffeste_V024_item (ffebld expr); -void ffeste_V024_finish (void); -void ffeste_V025_start (void); -void ffeste_V025_item (ffebld u, ffebld m, ffebld n, ffebld asv); -void ffeste_V025_finish (void); -void ffeste_V026 (ffestpFindStmt *info); -#endif /* Define macros. */ diff --git a/gcc/f/str.h b/gcc/f/str.h index 543eeeb..b3ac04e 100644 --- a/gcc/f/str.h +++ b/gcc/f/str.h @@ -1,5 +1,5 @@ /* str.h -- Private #include File (module.h template V1.0) - Copyright (C) 1995 Free Software Foundation, Inc. + Copyright (C) 1995, 2003 Free Software Foundation, Inc. Contributed by James Craig Burley. This file is part of GNU Fortran. @@ -30,11 +30,6 @@ the Free Software Foundation, 59 Temple Place - Suite 330, Boston, MA #ifndef GCC_F_STR_H #define GCC_F_STR_H -/* Simple definitions and enumerations. */ - -#define FFESTR_F90 0 /* Unsupported F90 stuff. */ -#define FFESTR_VXT 0 /* Unsupported VXT stuff. */ - /* Typedefs. */ -- cgit v1.1