Changeset 14107 for vendors/AGRIF/dev/LEX
- Timestamp:
- 2020-12-04T18:02:20+01:00 (3 years ago)
- Location:
- vendors/AGRIF/dev/LEX
- Files:
-
- 4 edited
Legend:
- Unmodified
- Added
- Removed
-
vendors/AGRIF/dev/LEX/Makefile.lex
r9140 r14107 1 1 LEX = flex -i 2 YACC = bison -t -v -g 2 YACC = /usr/bin/bison -t -v -g --graph 3 #YACC = byacc -t -v 3 4 4 5 all: main.c fortran.c 5 6 6 7 main.c : convert.tab.c convert.yy.c 7 cat convert.tab.c convert.yy.c > ../LIB/main.c8 cat convert.tab.c convert.yy.c > main.c 8 9 $(RM) convert.tab.c convert.yy.c 9 10 10 11 fortran.c : fortran.tab.c fortran.yy.c 11 cat fortran.tab.c fortran.yy.c > ../LIB/fortran.c12 cat fortran.tab.c fortran.yy.c > fortran.c 12 13 $(RM) fortran.tab.c fortran.yy.c 13 14 … … 29 30 30 31 clean-all: clean 31 $(RM) ../LIB/main.c ../LIB/fortran.c32 $(RM) main.c fortran.c -
vendors/AGRIF/dev/LEX/convert.y
r9140 r14107 130 130 int infreegiven ; 131 131 int infixedgiven ; 132 int lengthmainfile;133 132 134 133 char filetoparse[LONG_FNAME]; … … 160 159 tmpuselocallist = (listusemodule *) NULL; 161 160 List_ContainsSubroutine = (listnom *) NULL; 161 List_Do_labels = (listname *) NULL; 162 162 oldfortran_out = (FILE *) NULL; 163 163 164 if (argc < 2) print_usage(); 165 164 if ( argc < 2 ) 165 print_usage(); 166 166 167 strcpy(config_file, argv[1]); 167 168 strcpy(work_dir, "."); … … 257 258 strcpy(filetoparse, argv[i+1]); 258 259 i++; 259 lengthmainfile = strlen(filetoparse); 260 if (!strcasecmp(&filetoparse[lengthmainfile-4], ".f90")) 261 { 262 infixed = 0; 263 infree = 1; 264 } 265 else 266 { 267 infixed = 1; 268 infree = 0; 269 } 260 infree = (strstr(filetoparse, ".f90") != NULL) || (strstr(filetoparse, ".F90") != NULL); 261 infixed = ! infree; 270 262 } 271 263 else if (!strcasecmp(argv[i], "-free")) … … 400 392 /* Build new subroutines */ 401 393 firstpass = 0; 394 /* 395 printf("**********************************\n"); 396 printf("SECOND PASSES \n"); 397 printf("**********************************\n"); 398 */ 402 399 process_fortran(filetoparse); 403 400 -
vendors/AGRIF/dev/LEX/fortran.lex
r9140 r14107 39 39 %s character 40 40 %x donottreat 41 %x donottreat_interface 42 %x includestate 41 43 %s fortran77style 42 44 %s fortran90style … … 47 49 extern FILE * yyin; 48 50 #define MAX_INCLUDE_DEPTH 30 51 #define YY_BUF_SIZE 64000 49 52 YY_BUFFER_STATE include_stack[MAX_INCLUDE_DEPTH]; 50 int line_num_input = 1;53 int line_num_input = 0; 51 54 int newlinef90 = 0; 52 char tmpc; 53 #define PRINT_LINE_NUM() // { fprintf(stderr,"== Parsing l.%4d...\n", line_num_input); } 54 #define INCREMENT_LINE_NUM() { line_num_input++; PRINT_LINE_NUM(); } 55 56 /******************************************************************************/ 57 /**************PETITS PB NON PREVUS *******************************************/ 58 /******************************************************************************/ 59 /* NEXTLINF77 un ligne fortran 77 peut commencer par - &a=b or on */ 60 /* a prevu seulement & a=b avec l'espace entre le symbole */ 61 /* de la 7eme et le debut de la ligne de commande */ 62 /* le ! est aussi interdit comme symbole de la 7 eme colonne */ 63 /* Normalement NEXTLINEF77 \n+[ ]{5}[^ ] */ 64 /******************************************************************************/ 65 #define YY_USER_ACTION if (firstpass == 0) ECHO; 55 int tmpc; 56 57 int lastwasendofstmt = 1; 58 59 extern char linebuf1[1024]; 60 extern char linebuf2[1024]; 61 62 int count_newlines(const char* str_in) 63 { 64 int k, i = 0; 65 for( k=0 ; k<strlen(str_in) ; k++) 66 if (str_in[k] == '\n') i++; 67 return i; 68 } 69 70 #define PRINT_LINE_NUM() // { fprintf(stderr,"== Parsing l.%4d...\n", line_num_input); } 71 #define INCREMENT_LINE_NUM() { line_num_input+=count_newlines(fortran_text) ; PRINT_LINE_NUM(); } 72 #define YY_USER_ACTION { if (increment_nbtokens !=0) token_since_endofstmt++; increment_nbtokens = 1; if (token_since_endofstmt>=1) lastwasendofstmt=0; /*printf("VALLIJSDFLSD = %d %d %s \n",lastwasendofstmt,token_since_endofstmt,fortran_text); */ if (firstpass) { strcpy(linebuf1, linebuf2); strncpy(linebuf2, fortran_text,80);} \ 73 else {my_position_before=setposcur();/*printf("muposition = %d\n",my_position_before);*/ECHO;} } 74 #define YY_BREAK {/*printf("VALL = %d %d\n",lastwasendofstmt,token_since_endofstmt);*/if (token_since_endofstmt>=1) lastwasendofstmt=0; break;} 66 75 67 76 void out_of_donottreat(void); … … 69 78 %} 70 79 71 REAL8 "real*8"[ \t]*"(a-h,o-z)"72 73 80 SLASH "/" 74 DSLASH "/"[ \t]*"/"75 81 HEXA Z\'[0-9a-fA-F]+\' 76 NAME [a-zA-Z\_][a-zA-Z0-9\_]*77 82 INTEGER [0-9]+ 78 83 NAME [a-zA-Z][a-zA-Z0-9\_]* 79 84 EXPONENT [edq][-+]?{INTEGER} 80 85 81 BEG_DNT ^[C!]"$AGRIF_DO_NOT_TREAT"[ \t]* \n82 END_DNT ^[C!]"$AGRIF_END_DO_NOT_TREAT"[ \t]* \n86 BEG_DNT ^[C!]"$AGRIF_DO_NOT_TREAT"[ \t]*([ \t\n]*(!.*\n)*)+\n 87 END_DNT ^[C!]"$AGRIF_END_DO_NOT_TREAT"[ \t]*([ \t\n]*(!.*\n)*)+\n 83 88 84 89 BEG_INTERFACE ^[ \t]*interface … … 87 92 ASSIGNTYPE "assignment"[ \t]*"("[ \t]*[-+=]+[ \t]*")" 88 93 89 COMM_F77 ^ ([Cc*](([ \t]*\n)|([^AaHhOo\n].*\n)))90 COMM_F90 ^[ \t]*!.*\n94 COMM_F77 ^[c*].*\n 95 COMM_F90_1 ^([ \t\n]*(!.*\n)*)+\n 91 96 COMM_F90_2 !.* 92 NEXTLINEF90 "&".*\n+ 93 NEXTLINEF77 [\n \t]*\n[ \t]{5}("&"|"+"|"$"|"*"|"1"|"2"|"3"|"4"|"5"|"6"|"7"|"8"|"9"|"."|"#") 94 95 LABEL ^(((" "|[0-9]){1,5})|([ \t]{1,5}))[ &]+ 97 NEXTLINEF90 &([ \t\n]|(!.*\n))* 98 NEXTLINEF77 \n(([c*].*\n)|(([ \t]{0,4}|[ \t]{6,})!.*\n)|[\n])*[ ]{5}([a-z0-9&+$*.#/!;]) 99 LABEL ^[ 0-9]{1,5}[ \t]+ 96 100 97 101 %% … … 99 103 if (infree) BEGIN(fortran90style) ; 100 104 101 {REAL8} { return TOK_REAL8; }102 105 subroutine { return TOK_SUBROUTINE; } 103 106 program { return TOK_PROGRAM; } 104 107 allocate { inallocate = 1; return TOK_ALLOCATE; } 108 continue { return TOK_CONTINUE; } 105 109 nullify { return TOK_NULLIFY; } 106 null[ ]*\([ ]*\) { return TOK_NULL_PTR; }107 110 deallocate { inallocate = 1; return TOK_DEALLOCATE; } 108 111 result { return TOK_RESULT; } 109 112 function { return TOK_FUNCTION; } 110 end[ \t]*program { strcpy(yylval.na,fortran_text); return TOK_ENDPROGRAM;}111 end[ \t]*module { strcpy(yylval.na,fortran_text); return TOK_ENDMODULE; }112 end[ \t]*subroutine { strcpy(yylval.na,fortran_text); return TOK_ENDSUBROUTINE;}113 end[ \t]*function { strcpy(yylval.na,fortran_text); return TOK_ENDFUNCTION;}114 113 end { strcpy(yylval.na,fortran_text); return TOK_ENDUNIT;} 115 include { pos_curinclude = setposcur()-9; return TOK_INCLUDE;} 116 ^[ \t]*use[ ]+ { strcpy(yylval.na,fortran_text); 117 tmpc = (char) input(); unput(tmpc); 118 if ( ( tmpc >= 'a' && tmpc <= 'z' ) || 119 ( tmpc >= 'A' && tmpc <= 'Z' ) ) return TOK_USE; 120 else return TOK_NAME; 121 } 114 include { pos_curinclude = setposcur()-9; BEGIN(includestate); } 115 use { return TOK_USE;} 122 116 rewind { return TOK_REWIND; } 123 117 implicit { return TOK_IMPLICIT; } 124 118 none { return TOK_NONE; } 125 119 call { return TOK_CALL; } 126 .true. { return TOK_TRUE; }127 .false. { return TOK_FALSE; }120 .true. { strcpy(yylval.na,fortran_text); return TOK_TRUE; } 121 .false. { strcpy(yylval.na,fortran_text); return TOK_FALSE; } 128 122 \=\> { return TOK_POINT_TO; } 129 123 {ASSIGNTYPE} { strcpy(yylval.na,fortran_text); return TOK_ASSIGNTYPE;} 130 124 \*\* { strcpy(yylval.na,fortran_text); return TOK_DASTER; } 131 \. [ \t]*eqv\. { strcpy(yylval.na,fortran_text); return TOK_EQV; }132 \.[ \t]*eq \. { strcpy(yylval.na,fortran_text); return TOK_EQ; }133 \. [ \t]*gt\. { strcpy(yylval.na,fortran_text); return TOK_GT; }134 \. [ \t]*ge\. { strcpy(yylval.na,fortran_text); return TOK_GE; }135 \. [ \t]*lt\. { strcpy(yylval.na,fortran_text); return TOK_LT; }136 \. [ \t]*le\. { strcpy(yylval.na,fortran_text); return TOK_LE; }137 \. [ \t]*neqv\. { strcpy(yylval.na,fortran_text); return TOK_NEQV;}138 \.[ \t]*ne \. { strcpy(yylval.na,fortran_text); return TOK_NE; }139 \. [ \t]*not\. { strcpy(yylval.na,fortran_text); return TOK_NOT; }140 \. [ \t]*or\. { strcpy(yylval.na,fortran_text); return TOK_OR; }125 \.eqv\. { strcpy(yylval.na,fortran_text); return TOK_EQV; } 126 \.[ \t]*eq[ \t]*\. { strcpy(yylval.na,fortran_text); return TOK_EQ; } 127 \.gt\. { strcpy(yylval.na,fortran_text); return TOK_GT; } 128 \.ge\. { strcpy(yylval.na,fortran_text); return TOK_GE; } 129 \.lt\. { strcpy(yylval.na,fortran_text); return TOK_LT; } 130 \.le\. { strcpy(yylval.na,fortran_text); return TOK_LE; } 131 \.neqv\. { strcpy(yylval.na,fortran_text); return TOK_NEQV;} 132 \.[ \t]*ne[ \t]*\. { strcpy(yylval.na,fortran_text); return TOK_NE; } 133 \.not\. { strcpy(yylval.na,fortran_text); return TOK_NOT; } 134 \.or\. { strcpy(yylval.na,fortran_text); return TOK_OR; } 141 135 \.[ \t]*xor\. { strcpy(yylval.na,fortran_text); return TOK_XOR; } 142 \.[ \t]*and\. { strcpy(yylval.na,fortran_text); return TOK_AND; } 136 \.and\. { strcpy(yylval.na,fortran_text); return TOK_AND; } 137 \=\= { strcpy(yylval.na,fortran_text); return TOK_EQUALEQUAL; } 138 \/\= { strcpy(yylval.na,fortran_text); return TOK_SLASHEQUAL; } 139 \<\= { strcpy(yylval.na,fortran_text); return TOK_INFEQUAL; } 140 \>\= { strcpy(yylval.na,fortran_text); return TOK_SUPEQUAL; } 143 141 module { return TOK_MODULE; } 144 142 while { return TOK_WHILE; } 145 143 concurrent { return TOK_CONCURRENT; } 146 144 end[ \t]*do { return TOK_ENDDO; } 147 do { return TOK_PLAINDO;} 145 do[\ t]+{INTEGER} { strcpy(yylval.na,&fortran_text[2]); 146 if (testandextractfromlist(&List_Do_labels,&fortran_text[2]) == 1) 147 { 148 return TOK_PLAINDO_LABEL_DJVIEW; 149 } 150 else 151 { 152 List_Do_labels=Insertname(List_Do_labels,yylval.na,1); 153 return TOK_PLAINDO_LABEL; 154 } 155 } 156 do { increment_nbtokens = 0; return TOK_PLAINDO;} 148 157 real { strcpy(yylval.na,fortran_text); return TOK_REAL; } 149 158 integer { strcpy(yylval.na,fortran_text); return TOK_INTEGER; } … … 153 162 double[ \t]*precision { strcpy(yylval.na,fortran_text); return TOK_DOUBLEPRECISION; } 154 163 double[ \t]*complex { strcpy(yylval.na,fortran_text); return TOK_DOUBLECOMPLEX; } 155 complex { return TOK_COMPLEX; }164 complex { strcpy(yylval.na,fortran_text); return TOK_COMPLEX; } 156 165 allocatable { return TOK_ALLOCATABLE; } 157 166 close { return TOK_CLOSE; } … … 172 181 ^[ \t]*global[ \t]+ { return TOK_GLOBAL; } 173 182 external { return TOK_EXTERNAL; } 174 intent { return TOK_INTENT; }183 intent { intent_spec = 1; return TOK_INTENT; } 175 184 pointer { return TOK_POINTER; } 176 185 optional { return TOK_OPTIONAL; } 177 186 save { return TOK_SAVE; } 178 ^[ \t]*type[ \t]*\( { pos_cur_decl = setposcur()- 5; return TOK_TYPEPAR; }179 ^[ \t]*type [ \t\,]+{ return TOK_TYPE; }187 ^[ \t]*type[ \t]*\( { pos_cur_decl = setposcur()-strlen(fortran_text); return TOK_TYPEPAR; } 188 ^[ \t]*type/[ \t\,:]+ { return TOK_TYPE; } 180 189 end[ \t]*type { return TOK_ENDTYPE; } 181 190 stat { if (inallocate == 1) return TOK_STAT; else { strcpy(yylval.na,fortran_text); return TOK_NAME; } } 182 191 open { return TOK_OPEN; } 183 192 return { return TOK_RETURN; } 184 exit [^(]{ return TOK_EXIT; }193 exit { return TOK_EXIT; } 185 194 print { return TOK_PRINT; } 186 195 module[ \t]*procedure { return TOK_PROCEDURE; } 196 read[ \t]*\( { in_io_control_spec = 1; return TOK_READ_PAR; } 187 197 read { return TOK_READ; } 188 198 namelist { return TOK_NAMELIST; } 199 write[ \t]*\( { in_io_control_spec = 1; return TOK_WRITE_PAR; } 189 200 write { return TOK_WRITE; } 190 flush { return TOK_FLUSH; }201 flush { strcpy(yylval.na,fortran_text); return TOK_FLUSH; } 191 202 target { return TOK_TARGET; } 192 203 public { return TOK_PUBLIC; } 193 204 private { return TOK_PRIVATE; } 194 in { strcpy(yylval.na,fortran_text); return TOK_IN; } 195 ^[ \t]*data[ \t]+ { pos_curdata = setposcur()-strlen(fortran_text); Init_List_Data_Var(); return TOK_DATA; } 196 continue { return TOK_CONTINUE; } 205 in { strcpy(yylval.na,fortran_text); 206 if (intent_spec==1) 207 {return TOK_IN; } 208 else 209 { 210 return TOK_NAME; 211 } 212 } 213 ^[ \t]*data[ \t]+ { pos_curdata = setposcur()-strlen(fortran_text); /*Init_List_Data_Var();*/ return TOK_DATA; } 197 214 go[ \t]*to { return TOK_PLAINGOTO; } 198 out { strcpy(yylval.na,fortran_text); return TOK_OUT; } 199 inout { strcpy(yylval.na,fortran_text); return TOK_INOUT; } 215 out { strcpy(yylval.na,fortran_text); 216 if (intent_spec==1) 217 {return TOK_OUT; } 218 else 219 { 220 return TOK_NAME; 221 } 222 } 223 inout { strcpy(yylval.na,fortran_text); 224 if (intent_spec==1) 225 {return TOK_IN; } 226 else 227 { 228 return TOK_INOUT; 229 } 230 } 200 231 intrinsic { return TOK_INTRINSIC; } 201 232 then { return TOK_THEN; } … … 203 234 else { return TOK_ELSE; } 204 235 end[ \t]*if { return TOK_ENDIF; } 205 if { return TOK_LOGICALIF; } 206 sum[ \t]*\( { return TOK_SUM; } 207 max[ \t]*\( { return TOK_MAX; } 208 tanh { return TOK_TANH; } 209 maxval { return TOK_MAXVAL; } 210 trim { return TOK_TRIM; } 211 sqrt\( { return TOK_SQRT; } 236 if[ \t]*\(/(.*\)[ \t]*[\=|\+|\-]+.*\)) {strcpy(yylval.na,fortran_text); 237 return TOK_LOGICALIF_PAR; 238 } 239 if/([ \t]*\([^(]*\)[ \t]*[\=|\+|\-]+) {strcpy(yylval.na,fortran_text); 240 return TOK_NAME; 241 } 242 if[ \t]*\( {strcpy(yylval.na,fortran_text); 243 return TOK_LOGICALIF_PAR; 244 } 212 245 select[ \t]*case { return TOK_SELECTCASE; } 213 ^[ \t]*case[ \t]* { return TOK_CASE;}246 ^[ \t]*case[ \t]* { if (in_select_case_stmt > 0) return TOK_CASE ; else return TOK_NAME;} 214 247 default { return TOK_DEFAULT; } 215 248 end[ \t]*select { return TOK_ENDSELECT; } 216 249 file[ \t]*\= { return TOK_FILE; } 250 access[ \t]*\= { return TOK_ACCESS; } 251 action[ \t]*\= { return TOK_ACTION; } 252 iolength[ \t]*\= { return TOK_IOLENGTH; } 217 253 unit[ \t]*\= { return TOK_UNIT; } 254 opened[ \t]*\= { return TOK_OPENED; } 218 255 fmt[ \t]*\= { return TOK_FMT; } 219 256 nml[ \t]*\= { return TOK_NML; } 220 257 end[ \t]*\= { return TOK_END; } 221 258 eor[ \t]*\= { return TOK_EOR; } 259 len/([ \t]*\=) { 260 if (in_char_selector ==1) 261 return TOK_LEN; 262 else 263 { 264 strcpy(yylval.na,fortran_text); return TOK_NAME; 265 } 266 } 267 kind/([ \t]*\=) { 268 if ((in_char_selector==1) || (in_kind_selector == 1)) 269 return TOK_KIND; 270 else 271 { 272 strcpy(yylval.na,fortran_text); return TOK_NAME; 273 } 274 } 275 errmsg[ \t]*\= { return TOK_ERRMSG; } 276 mold[ \t]*\= { return TOK_MOLD; } 277 source[ \t]*\= { return TOK_SOURCE; } 278 position[ \t]*\= { return TOK_POSITION; } 279 iomsg[ \t]*\= { return TOK_IOMSG; } 280 iostat[ \t]*\= { return TOK_IOSTAT; } 222 281 err[ \t]*\= { return TOK_ERR; } 282 form[ \t]*\= { return TOK_FORM; } 283 name/([ \t]*\=) { 284 if (in_inquire==1) 285 return TOK_NAME_EQ; 286 else 287 { 288 strcpy(yylval.na,fortran_text); return TOK_NAME; 289 } 290 } 291 recl[ \t]*\= { return TOK_RECL; } 292 rec/([ \t]*\=) { if (in_io_control_spec == 1) 293 return TOK_REC; 294 else 295 { 296 strcpy(yylval.na,fortran_text); return TOK_NAME; 297 } 298 } 299 status/([ \t]*\=) { if (close_or_connect == 1) 300 return TOK_STATUS; 301 else 302 { 303 strcpy(yylval.na,fortran_text); return TOK_NAME; 304 } 305 } 306 status { strcpy(yylval.na,fortran_text); return TOK_NAME;} 223 307 exist[ \t]*\= { return TOK_EXIST; } 224 min[ \t]*\( { return TOK_MIN; }225 nint { return TOK_NINT; }226 float { return TOK_FLOAT; }227 exp { return TOK_EXP; }228 cos { return TOK_COS; }229 cosh { return TOK_COSH; }230 acos { return TOK_ACOS; }231 sin { return TOK_SIN; }232 sinh { return TOK_SINH; }233 asin { return TOK_ASIN; }234 log { return TOK_LOG; }235 tan { return TOK_TAN; }236 atan { return TOK_ATAN; }237 308 cycle { return TOK_CYCLE; } 238 abs[ \t]*\( { return TOK_ABS; }239 mod { return TOK_MOD; }240 sign[ \t]*\( { return TOK_SIGN; }241 minloc { return TOK_MINLOC; }242 maxloc { return TOK_MAXLOC; }243 minval { return TOK_MINVAL; }244 309 backspace { return TOK_BACKSPACE; } 245 310 :: { return TOK_FOURDOTS; } 311 \/[ \t]*({NEXTLINEF90}|{NEXTLINEF77})*[ \t]*\/ { strcpy(yylval.na,fortran_text); return TOK_DSLASH; } 246 312 \({SLASH} { return TOK_LEFTAB; } 247 313 {SLASH}\) { return TOK_RIGHTAB; } 248 format[ \t]*\((.|{NEXTLINEF90}|{NEXTLINEF77})*\) {249 return TOK_FORMAT; }250 314 {SLASH} { strcpy(yylval.na,fortran_text); return TOK_SLASH; } 251 DSLASH { strcpy(yylval.na,fortran_text); return TOK_DSLASH; } 252 (\')[^']*&{0,1}\n[ \t]*&{0,1}[^']*(\') { 253 strcpy(yylval.na,fortran_text); return TOK_CHAR_CUT; } 254 (\')[^']*(\') { strcpy(yylval.na,fortran_text);return TOK_CHAR_CONSTANT; } 255 (\")[^"]*(\") { strcpy(yylval.na,fortran_text);return TOK_CHAR_MESSAGE; } 256 {BEG_INTERFACE} { BEGIN(donottreat); } 257 <donottreat>{END_INTERFACE} { out_of_donottreat(); return '\n'; } 315 ((\')[^']*&{0,1}\n[ \t]*&{0,1}[^']*(\'))+ { 316 INCREMENT_LINE_NUM() ; strcpy(yylval.na,fortran_text); return TOK_CHAR_CUT; } 317 <includestate>((\')[^']*(\'))+ {Add_Include_1(fortran_text);} 318 <includestate>[ \t]* {} 319 <includestate>\n { 320 if (inmoduledeclare == 0 ) 321 { 322 pos_end=setposcur(); 323 RemoveWordSET_0(fortran_out,pos_curinclude,pos_end-pos_curinclude); 324 } 325 out_of_donottreat(); 326 } 327 ((\')[^']*(\'))+ { strcpy(yylval.na,fortran_text);return TOK_CHAR_CONSTANT; } 328 ((\")[^"]*(\"))+ { strcpy(yylval.na,fortran_text);return TOK_CHAR_MESSAGE; } 329 {BEG_INTERFACE} { BEGIN(donottreat_interface); } 330 <donottreat_interface>{END_INTERFACE} { out_of_donottreat(); return '\n'; } 331 <donottreat_interface>.*\n {INCREMENT_LINE_NUM() ; } 332 <fortran77style>{NAME}{NEXTLINEF77}[a-zA-Z0-9\_]+ {strcpy(yylval.na,fortran_text); removenewline(yylval.na); 333 return TOK_NAME; } 258 334 {NAME} { strcpy(yylval.na,fortran_text); return TOK_NAME; } 335 {INTEGER}\.[0-9]+ {strcpy(yylval.na,fortran_text); return TOK_CSTREAL; } 259 336 ({INTEGER}\.[0-9]*)/[^"and."|"false."|"true."|"eq."|"or."|"gt."|"ge."|"lt."|"le."|"not."|"ne."] { // REAL1 260 337 strcpy(yylval.na,fortran_text); return TOK_CSTREAL; } 261 338 (({INTEGER}\.[0-9]+|[0-9]*\.{INTEGER}){EXPONENT}?)|{INTEGER}(\.)?{EXPONENT} { // REAL2 262 339 strcpy(yylval.na,fortran_text); return TOK_CSTREAL; } 263 {INTEGER} { strcpy(yylval.na,fortran_text); return TOK_CSTINT; } 340 {INTEGER} { strcpy(yylval.na,fortran_text); 341 if (lastwasendofstmt == 0) 342 return TOK_CSTINT; 343 else 344 if (testandextractfromlist(&List_Do_labels,fortran_text) == 1) 345 { 346 removefromlist(&List_Do_labels,yylval.na); 347 return TOK_LABEL_DJVIEW; 348 } 349 else 350 { 351 return TOK_LABEL; 352 } 353 } 264 354 \$ {} 265 355 \. {} 266 \(|\)|:|\[|\]|\+|\-|\* { strcpy(yylval.na,fortran_text); return (int) *fortran_text; } 356 \(/([ \t]*[\+\-]?[a-zA-Z0-9]+[\.]*[0-9]*(\_({INTEGER}|{NAME}))?[ \t]*\,[ \t]*[\+\-]?[a-zA-Z0-9]+[\.]*[0-9]*(\_({INTEGER}|{NAME}))?[ \t]*\)) { 357 in_complex_literal = -1; 358 return (int) *fortran_text; 359 } 360 \(|\)|:|\[|\]|\+|\-|\*|\_ { strcpy(yylval.na,fortran_text); return (int) *fortran_text; } 267 361 \% { strcpy(yylval.na,fortran_text); return (int) *fortran_text; } 268 \; { return TOK_SEMICOLON; }269 \, { return (int) *fortran_text; }362 \; { lastwasendofstmt=1; token_since_endofstmt = 0; return TOK_SEMICOLON; } 363 \, { if (in_complex_literal==-1) {return TOK_COMMACOMPLEX; in_complex_literal=0;} else; return (int) *fortran_text; } 270 364 \= { return (int) *fortran_text; } 271 365 \< { return (int) *fortran_text; } 272 366 \> { return (int) *fortran_text; } 273 \n { INCREMENT_LINE_NUM() ; return '\n'; } 274 ^[ ]*$ {} 275 [ \t]+ {} 276 {LABEL} { if (newlinef90 == 0) return TOK_LABEL; else newlinef90 = 0; } 367 \n { INCREMENT_LINE_NUM() ; lastwasendofstmt=1; token_since_endofstmt = 0; increment_nbtokens = 0; return '\n'; } 368 [ \t]+ {increment_nbtokens = 0;} 369 <fortran77style>{LABEL}[ \t]*format[ \t]*\((.|{NEXTLINEF90}|{NEXTLINEF77})*\) { 370 return TOK_LABEL_FORMAT; } 371 <fortran90style>^[ \t]*{INTEGER}[ \t]*format[ \t]*\((.|{NEXTLINEF90})*\) {return TOK_LABEL_FORMAT; } 277 372 {NEXTLINEF90} { INCREMENT_LINE_NUM() ; newlinef90=1; } 278 {NEXTLINEF77} { INCREMENT_LINE_NUM() ; } 279 280 {BEG_DNT} { INCREMENT_LINE_NUM() ; BEGIN(donottreat); } 281 <donottreat>{END_DNT} { out_of_donottreat(); return '\n'; } 282 <donottreat>.*\n { INCREMENT_LINE_NUM() ; } 283 <fortran77style>{COMM_F77} { INCREMENT_LINE_NUM() ; } 284 {COMM_F90} { INCREMENT_LINE_NUM() ; } 285 {COMM_F90_2} {} 373 <fortran77style>{NEXTLINEF77} { INCREMENT_LINE_NUM() ;} 374 375 {BEG_DNT} {INCREMENT_LINE_NUM() ; BEGIN(donottreat); } 376 <donottreat>{END_DNT} {out_of_donottreat(); return '\n'; } 377 <donottreat>.*\n {INCREMENT_LINE_NUM() ; } 378 <fortran77style>{COMM_F77} {INCREMENT_LINE_NUM() ; increment_nbtokens = 0;} 379 {COMM_F90_1} {INCREMENT_LINE_NUM() ; increment_nbtokens = 0;} 380 {COMM_F90_2} {increment_nbtokens = 0;} 381 <<EOF>> {endoffile = 1; yyterminate();} 286 382 %% 287 383 -
vendors/AGRIF/dev/LEX/fortran.y
r12420 r14107 42 42 43 43 extern int line_num_input; 44 extern char *fortran_text;45 44 46 45 char c_selectorname[LONG_M]; … … 50 49 int c_selectorgiven=0; 51 50 listvar *curlistvar; 51 int in_select_case_stmt=0; 52 52 typedim c_selectordim; 53 53 listcouple *coupletmp; 54 54 int removeline=0; 55 int token_since_endofstmt = 0; 56 int increment_nbtokens = 1; 57 int in_complex_literal = 0; 58 int close_or_connect = 0; 59 int in_io_control_spec = 0; 60 int intent_spec = 0; 61 long int my_position; 62 long int my_position_before; 63 int suborfun = 0; 64 int indeclaration = 0; 65 int endoffile = 0; 66 int in_inquire = 0; 67 int in_char_selector = 0; 68 int in_kind_selector =0; 69 int char_length_toreset = 0; 70 71 typedim my_dim; 72 55 73 listvar *test; 74 75 char linebuf1[1024]; 76 char linebuf2[1024]; 56 77 57 78 int fortran_error(const char *s) 58 79 { 59 printf("%s line %d, file %s motclef = |%s|\n", s, line_num_input, cur_filename, fortran_text); 80 if (endoffile == 1) 81 { 82 endoffile = 0; 83 return 0; 84 } 85 printf("%s line %d, file %s culprit = |%s|\n", s, line_num_input, cur_filename, strcat(linebuf1, linebuf2)); 60 86 exit(1); 61 87 } … … 94 120 %token TOK_PROGRAM 95 121 %token TOK_FUNCTION 96 %token TOK_FORMAT 122 %token TOK_LABEL_FORMAT 123 %token TOK_LABEL_CONTINUE 124 %token TOK_LABEL_END_DO 97 125 %token TOK_MAX 98 126 %token TOK_TANH 127 %token TOK_COMMENT 99 128 %token TOK_WHERE 100 129 %token TOK_ELSEWHEREPAR … … 109 138 %token TOK_SELECTCASE 110 139 %token TOK_FILE 140 %token TOK_REC 141 %token TOK_NAME_EQ 142 %token TOK_IOLENGTH 143 %token TOK_ACCESS 144 %token TOK_ACTION 145 %token TOK_FORM 146 %token TOK_RECL 147 %token TOK_STATUS 111 148 %token TOK_UNIT 149 %token TOK_OPENED 112 150 %token TOK_FMT 113 151 %token TOK_NML 114 152 %token TOK_END 115 153 %token TOK_EOR 154 %token TOK_EOF 116 155 %token TOK_ERR 156 %token TOK_POSITION 157 %token TOK_IOSTAT 158 %token TOK_IOMSG 117 159 %token TOK_EXIST 118 160 %token TOK_MIN 119 161 %token TOK_FLOAT 120 162 %token TOK_EXP 163 %token TOK_LEN 121 164 %token TOK_COS 122 165 %token TOK_COSH … … 139 182 %token TOK_MAXLOC 140 183 %token TOK_EXIT 184 %token TOK_KIND 185 %token TOK_MOLD 186 %token TOK_SOURCE 187 %token TOK_ERRMSG 141 188 %token TOK_MINVAL 142 189 %token TOK_PUBLIC … … 150 197 %token TOK_PRINT 151 198 %token TOK_PLAINGOTO 152 %token TOK_LOGICALIF 199 %token <na> TOK_LOGICALIF 200 %token <na> TOK_LOGICALIF_PAR 153 201 %token TOK_PLAINDO 154 202 %token TOK_CONTAINS … … 162 210 %token TOK_CLOSE 163 211 %token TOK_INQUIRE 212 %token TOK_WRITE_PAR 164 213 %token TOK_WRITE 165 %token TOK_FLUSH 214 %token <na> TOK_FLUSH 215 %token TOK_READ_PAR 166 216 %token TOK_READ 167 217 %token TOK_REWIND … … 192 242 %token TOK_PROCEDURE 193 243 %token TOK_STOP 194 %token TOK_REAL8195 244 %token TOK_FOURDOTS 196 245 %token <na> TOK_HEXA … … 214 263 %token <na> TOK_NOT 215 264 %token <na> TOK_AND 265 %token <na> TOK_EQUALEQUAL 266 %token <na> TOK_SLASHEQUAL 267 %token <na> TOK_INFEQUAL 268 %token <na> TOK_SUPEQUAL 216 269 %token <na> TOK_TRUE 217 270 %token <na> TOK_FALSE 218 271 %token <na> TOK_LABEL 272 %token <na> TOK_LABEL_DJVIEW 273 %token <na> TOK_PLAINDO_LABEL_DJVIEW 274 %token <na> TOK_PLAINDO_LABEL 219 275 %token <na> TOK_TYPE 220 276 %token <na> TOK_TYPEPAR 221 277 %token <na> TOK_ENDTYPE 278 %token TOK_COMMACOMPLEX 222 279 %token <na> TOK_REAL 223 280 %token <na> TOK_INTEGER … … 246 303 %token '>' 247 304 %type <l> dcl 248 %type <l> after_type249 305 %type <l> dimension 306 %type <l> array-name-spec-list 250 307 %type <l> paramlist 251 308 %type <l> args 309 %type <na> declaration-type-spec 252 310 %type <l> arglist 253 311 %type <lc> only_list 312 %type <lc> only-list 313 %type <lc> opt-only-list 314 %type <lc> only 254 315 %type <lc> only_name 255 %type <lc> rename_list 256 %type <lc> rename_name 316 %type <lc> rename-list 317 %type <lc> opt-rename-list 318 %type <lc> rename 257 319 %type <d> dims 258 320 %type <d> dimlist … … 261 323 %type <na> comblock 262 324 %type <na> name_routine 325 %type <na> type-param-value 263 326 %type <na> opt_name 327 %type <na> constant-expr 328 %type <na> ac-implied-do 329 %type <na> subroutine-name 330 %type <l> opt-dummy-arg-list-par 331 %type <l> opt-dummy-arg-list 332 %type <l> dummy-arg-list 333 %type <l> named-constant-def-list 334 %type <v> named-constant-def 335 %type <na> ac-do-variable 336 %type <na> data-i-do-variable 337 %type <na> data-stmt-constant 338 %type <na> do-variable 339 %type <na> ac-implied-do-control 340 %type <na> label 341 %type <na> opt-label 342 %type <na> label-djview 343 %type <na> opt-label-djview 264 344 %type <na> type 265 %type <na> word_endsubroutine 266 %type <na> word_endfunction 267 %type <na> word_endprogram 268 %type <na> word_endunit 345 %type <na> real-literal-constant 346 %type <l> type-declaration-stmt 347 %type <d> array-spec 348 %type <d> assumed-shape-spec-list 349 %type <d> deferred-shape-spec-list 350 %type <d> assumed-size-spec 351 %type <d> implied-shape-spec-list 269 352 %type <na> typespec 353 %type <na> null-init 354 %type <na> initial-data-target 355 %type <na> intent-spec 270 356 %type <na> string_constant 357 %type <na> access-id 358 %type <na> dummy-arg-name 359 %type <na> common-block-name 360 %type <na> function-name 361 %type <na> dummy-arg 362 %type <na> lower-bound 363 %type <na> upper-bound 364 %type <na> scalar-constant-subobject 365 %type <na> opt-data-stmt-star 271 366 %type <na> simple_const 367 %type <na> opt-char-selector 368 %type <na> char-selector 272 369 %type <na> ident 273 370 %type <na> intent_spec 371 %type <na> kind-param 274 372 %type <na> signe 373 %type <na> scalar-int-constant-expr 275 374 %type <na> opt_signe 375 %type <dim1> explicit-shape-spec 376 %type <d> explicit-shape-spec-list 377 %type <dim1> assumed-shape-spec 378 %type <dim1> deferred-shape-spec 276 379 %type <na> filename 277 380 %type <na> attribute … … 279 382 %type <na> begin_array 280 383 %type <na> clause 384 %type <na> only-use-name 385 %type <na> generic-spec 281 386 %type <na> arg 387 %type <d> opt-array-spec-par 388 %type <d> opt-explicit-shape-spec-list-comma 389 %type <d> explicit-shape-spec-list-comma 282 390 %type <na> uexpr 391 %type <na> section_subscript_ambiguous 283 392 %type <na> minmaxlist 393 %type <na> subscript 394 %type <na> subscript-triplet 395 %type <na> vector-subscript 284 396 %type <na> lhs 285 %type <na> vec286 397 %type <na> outlist 287 398 %type <na> other 399 %type <na> int-constant-expr 288 400 %type <na> dospec 289 401 %type <na> expr_data … … 298 410 %type <na> opt_expr 299 411 %type <na> optexpr 412 %type <v> entity-decl 413 %type <l> entity-decl-list 300 414 %type <lnn> data_stmt_value_list 415 %type <lnn> data-stmt-value-list 416 %type <lnn> access-id-list 417 %type <lnn> opt-access-id-list 418 %type <na> data-stmt-value 419 %type <l> data-stmt-object-list 420 %type <l> data-i-do-object-list 421 %type <v> data-stmt-object 422 %type <v> data-i-do-object 301 423 %type <lnn> datanamelist 302 424 %type <na> after_slash 303 425 %type <na> after_equal 304 426 %type <na> predefinedfunction 427 %type <na> equiv-op 428 %type <na> or-op 429 %type <na> and-op 430 %type <na> not-op 431 %type <na> equiv-operand 432 %type <na> or-operand 433 %type <na> and-operand 434 %type <na> mult-operand 435 %type <na> rel-op 436 %type <na> concat-op 437 %type <na> add-operand 438 %type <na> add-op 439 %type <na> power-op 440 %type <na> section-subscript-list 441 %type <na> opt-lower-bound-2points 442 %type <na> mult-op 443 %type <na> array-constructor 305 444 %type <na> expr 445 %type <na> function-reference 446 %type <na> literal-constant 447 %type <na> named-constant 448 %type <na> ac-value-list 449 %type <na> ac-value 450 %type <na> intrinsic-type-spec 451 %type <na> opt-kind-selector 452 %type <na> char-literal-constant 453 %type <na> logical-literal-constant 454 %type <na> real-part 455 %type <na> imag-part 456 %type <na> sign 457 %type <na> signed-int-literal-constant 458 %type <na> int-literal-constant 459 %type <na> signed-real-literal-constant 460 %type <na> complex-literal-constant 461 %type <na> actual-arg-spec-list 462 %type <na> procedure-designator 463 %type <na> constant 464 %type <na> data-ref 465 %type <v> structure-component 466 %type <v> scalar-structure-component 467 %type <na> int-expr 468 %type <na> ac-spec 469 %type <na> type-spec 470 %type <na> derived-type-spec 471 %type <v> part-ref 472 %type <na> opt-part-ref 473 %type <na> actual-arg-spec 474 %type <na> kind-selector 475 %type <na> actual-arg 476 %type <na> section-subscript 477 %type <na> keyword 478 %type <na> primary 479 %type <na> specification-expr 480 %type <v> variable 481 %type <v> data-implied-do 482 %type <na> substring-range 483 %type <v> designator 484 %type <na> object-name 485 %type <na> object-name-noident 486 %type <na> array-element 487 %type <na> array-section 488 %type <na> scalar-variable-name 489 %type <na> scalar-constant 490 %type <na> variable-name 491 %type <na> opt-subscript 492 %type <na> stride 493 %type <na> opt-scalar-int-expr 494 %type <na> scalar-int-expr 495 %type <na> level-1-expr 496 %type <na> level-2-expr 497 %type <na> level-3-expr 498 %type <na> level-4-expr 499 %type <na> level-5-expr 306 500 %type <na> ubound 307 501 %type <na> operation … … 311 505 312 506 %% 313 input : 507 /* R201 : program */ 508 /*program: line-break 509 | program-unit 510 | program program-unit 511 ; 512 */ 513 514 input: 314 515 | input line 315 516 ; 316 line 517 line: line-break 317 518 | suite_line_list 318 | TOK_LABEL suite_line_list319 519 | error {yyerrok;yyclearin;} 320 520 ; 321 line-break: 322 '\n' fin_line521 line-break: '\n' fin_line 522 {token_since_endofstmt = 0; increment_nbtokens = 0;} 323 523 | TOK_SEMICOLON 524 | TOK_EOF 324 525 | line-break '\n' fin_line 325 526 | line-break TOK_SEMICOLON 326 | line-break TOK_LABEL327 527 ; 328 528 suite_line_list : … … 331 531 | suite_line_list TOK_SEMICOLON suite_line 332 532 ; 333 suite_line : 334 entry fin_line /* subroutine, function, module */ 335 | spec fin_line /* declaration */ 533 suite_line:program-unit 336 534 | TOK_INCLUDE filename fin_line 337 535 { … … 342 540 } 343 541 } 542 | TOK_COMMENT 543 ; 544 /* 545 suite_line: 546 entry fin_line subroutine, function, module 547 | spec fin_line declaration 548 | TOK_INCLUDE filename fin_line 549 { 550 if (inmoduledeclare == 0 ) 551 { 552 pos_end = setposcur(); 553 RemoveWordSET_0(fortran_out,pos_curinclude,pos_end-pos_curinclude); 554 } 555 } 344 556 | execution-part-construct 345 557 ; 346 347 fin_line : { pos_cur = setposcur(); } 348 ; 349 558 */ 559 560 fin_line: { pos_cur = setposcur(); } 561 ; 562 563 /* R202 : program-unit */ 564 program-unit: main-program 565 | external-subprogram 566 | module 567 ; 568 569 /*R203 : external-subprogram */ 570 external-subprogram: function-subprogram 571 | subroutine-subprogram 572 ; 573 350 574 opt_recursive : { isrecursive = 0; } 351 575 | TOK_RECURSIVE { isrecursive = 1; } … … 356 580 ; 357 581 358 entry : opt_recursive TOK_SUBROUTINE name_routine arglist359 {360 insubroutinedeclare = 1;361 if ( firstpass )362 Add_SubroutineArgument_Var_1($4);363 else364 WriteBeginof_SubLoop();365 }366 | TOK_PROGRAM name_routine367 {368 insubroutinedeclare = 1;369 inprogramdeclare = 1;370 /* in the second step we should write the head of */371 /* the subroutine sub_loop_<subroutinename> */372 if ( ! firstpass )373 WriteBeginof_SubLoop();374 }375 | opt_recursive TOK_FUNCTION name_routine arglist opt_result376 {377 insubroutinedeclare = 1;378 strcpy(DeclType, "");379 /* we should to list of the subroutine argument the */380 /* name of the function which has to be defined */381 if ( firstpass )382 {383 Add_SubroutineArgument_Var_1($4);384 if ( ! is_result_present )385 Add_FunctionType_Var_1($3);386 }387 else388 /* in the second step we should write the head of */389 /* the subroutine sub_loop_<subroutinename> */390 WriteBeginof_SubLoop();391 }392 | TOK_MODULE TOK_NAME393 {394 GlobalDeclaration = 0;395 strcpy(curmodulename,$2);396 strcpy(subroutinename,"");397 Add_NameOfModule_1($2);398 if ( inmoduledeclare == 0 )399 {400 /* To know if there are in the module declaration */401 inmoduledeclare = 1;402 /* to know if a module has been met */403 inmodulemeet = 1;404 /* to know if we are after the keyword contains */405 aftercontainsdeclare = 0 ;406 }407 }408 ;409 410 /* R312 : label */411 label: TOK_CSTINT412 | label TOK_CSTINT413 ;414 415 582 name_routine : TOK_NAME { strcpy($$, $1); strcpy(subroutinename, $1); } 416 583 ; … … 419 586 arglist : { if ( firstpass ) $$=NULL; } 420 587 | '(' ')' { if ( firstpass ) $$=NULL; } 421 | '(' args ')' { if ( firstpass ) $$=$2; }588 | '(' {in_complex_literal=0;} args ')' { if ( firstpass ) $$=$3; } 422 589 ; 423 590 arglist_after_result: 424 591 | '(' ')' 425 | '(' args ')' { if ( firstpass ) Add_SubroutineArgument_Var_1($2); }592 | '(' {in_complex_literal=0;} args ')' { if ( firstpass ) Add_SubroutineArgument_Var_1($3); } 426 593 ; 427 594 args : arg … … 452 619 | '*' { strcpy($$,"*"); } 453 620 ; 454 spec : type after_type 455 | TOK_TYPE opt_spec opt_sep opt_name { inside_type_declare = 1; } 456 | TOK_ENDTYPE opt_name { inside_type_declare = 0; } 457 | TOK_POINTER list_couple 458 | before_parameter '(' paramlist ')' 459 { 460 if ( ! inside_type_declare ) 461 { 462 if ( firstpass ) 463 { 464 if ( insubroutinedeclare ) Add_Parameter_Var_1($3); 465 else Add_GlobalParameter_Var_1($3); 466 } 467 else 468 { 469 pos_end = setposcur(); 470 RemoveWordSET_0(fortran_out, pos_cur_decl, pos_end-pos_cur_decl); 471 } 472 } 473 VariableIsParameter = 0 ; 474 } 475 | before_parameter paramlist 476 { 477 if ( ! inside_type_declare ) 478 { 479 if ( firstpass ) 480 { 481 if ( insubroutinedeclare ) Add_Parameter_Var_1($2); 482 else Add_GlobalParameter_Var_1($2); 483 } 484 else 485 { 486 pos_end = setposcur(); 487 RemoveWordSET_0(fortran_out,pos_cur_decl,pos_end-pos_cur_decl); 488 } 489 } 490 VariableIsParameter = 0 ; 491 } 492 | common 493 | save 494 { 495 pos_end = setposcur(); 496 RemoveWordSET_0(fortran_out,pos_cursave,pos_end-pos_cursave); 497 } 498 | implicit 499 | dimension 500 { 501 /* if the variable is a parameter we can suppose that is */ 502 /* value is the same on each grid. It is not useless to */ 503 /* create a copy of it on each grid */ 504 if ( ! inside_type_declare ) 505 { 506 if ( firstpass ) 507 { 508 Add_Globliste_1($1); 509 /* if variableparamlists has been declared in a subroutine */ 510 if ( insubroutinedeclare ) Add_Dimension_Var_1($1); 511 } 512 else 513 { 514 pos_end = setposcur(); 515 RemoveWordSET_0(fortran_out,pos_curdimension,pos_end-pos_curdimension); 516 } 517 } 518 PublicDeclare = 0; 519 PrivateDeclare = 0; 520 ExternalDeclare = 0; 521 strcpy(NamePrecision,""); 522 c_star = 0; 523 InitialValueGiven = 0 ; 524 strcpy(IntentSpec,""); 525 VariableIsParameter = 0 ; 526 Allocatabledeclare = 0 ; 527 Targetdeclare = 0 ; 528 SaveDeclare = 0; 529 pointerdeclare = 0; 530 optionaldeclare = 0 ; 531 dimsgiven=0; 532 c_selectorgiven=0; 533 strcpy(nameinttypename,""); 534 strcpy(c_selectorname,""); 535 } 536 | public 537 { 538 if (firstpass == 0) 539 { 540 if ($1) 541 { 542 removeglobfromlist(&($1)); 543 pos_end = setposcur(); 544 RemoveWordSET_0(fortran_out,pos_cur,pos_end-pos_cur); 545 writelistpublic($1); 546 } 547 } 548 } 549 | private 550 | use_stat 551 | module_proc_stmt 552 | namelist 553 | TOK_BACKSPACE '(' expr ')' 554 | TOK_EXTERNAL opt_sep use_name_list 555 | TOK_INTRINSIC opt_sep use_intrinsic_list 556 | TOK_EQUIVALENCE list_expr_equi 557 | data_stmt '\n' 558 { 559 /* we should remove the data declaration */ 560 pos_end = setposcur(); 561 RemoveWordSET_0(fortran_out,pos_curdata,pos_end-pos_curdata); 562 563 if ( aftercontainsdeclare == 1 && firstpass == 0 ) 564 { 565 ReWriteDataStatement_0(fortran_out); 566 pos_end = setposcur(); 567 } 568 } 569 ; 621 570 622 opt_spec : 571 623 | access_spec … … 619 671 | list_expr_equi1 ',' ident dims 620 672 ; 621 list_expr 673 list_expr: 622 674 expr 623 675 | list_expr ',' expr 624 676 ; 625 opt_sep 677 opt_sep: 626 678 | TOK_FOURDOTS 627 679 ; 628 after_type : 629 dcl nodimsgiven 630 { 631 /* if the variable is a parameter we can suppose that is*/ 632 /* value is the same on each grid. It is not useless */ 633 /* to create a copy of it on each grid */ 634 if ( ! inside_type_declare ) 635 { 636 pos_end = setposcur(); 637 RemoveWordSET_0(fortran_out,pos_cur_decl,pos_end-pos_cur_decl); 638 ReWriteDeclarationAndAddTosubroutine_01($1); 639 pos_cur_decl = setposcur(); 640 if ( firstpass == 0 && GlobalDeclaration == 0 641 && insubroutinedeclare == 0 ) 642 { 643 fprintf(fortran_out,"\n#include \"Module_Declar_%s.h\"\n", curmodulename); 644 sprintf(ligne, "Module_Declar_%s.h", curmodulename); 645 module_declar = open_for_write(ligne); 646 GlobalDeclaration = 1 ; 647 pos_cur_decl = setposcur(); 648 } 649 $$ = $1; 650 651 if ( firstpass ) 652 { 653 Add_Globliste_1($1); 654 if ( insubroutinedeclare ) 655 { 656 if ( pointerdeclare ) Add_Pointer_Var_From_List_1($1); 657 Add_Parameter_Var_1($1); 658 } 659 else 660 Add_GlobalParameter_Var_1($1); 661 662 /* If there's a SAVE declaration in module's subroutines we should */ 663 /* remove it from the subroutines declaration and add it in the */ 664 /* global declarations */ 665 if ( aftercontainsdeclare && SaveDeclare ) 666 { 667 if ( inmodulemeet ) Add_SubroutineDeclarationSave_Var_1($1); 668 else Add_Save_Var_dcl_1($1); 669 } 670 } 671 } 672 else 673 { 674 $$ = (listvar *) NULL; 675 } 676 PublicDeclare = 0; 677 PrivateDeclare = 0; 678 ExternalDeclare = 0; 679 strcpy(NamePrecision,""); 680 c_star = 0; 681 InitialValueGiven = 0 ; 682 strcpy(IntentSpec,""); 683 VariableIsParameter = 0 ; 684 Allocatabledeclare = 0 ; 685 Targetdeclare = 0 ; 686 SaveDeclare = 0; 687 pointerdeclare = 0; 688 optionaldeclare = 0 ; 689 dimsgiven=0; 690 c_selectorgiven=0; 691 strcpy(nameinttypename,""); 692 strcpy(c_selectorname,""); 693 GlobalDeclarationType = 0; 694 } 695 | before_function name_routine arglist 696 { 697 insubroutinedeclare = 1; 698 699 if ( firstpass ) 700 { 701 Add_SubroutineArgument_Var_1($3); 702 Add_FunctionType_Var_1($2); 703 } 704 else 705 WriteBeginof_SubLoop(); 706 707 strcpy(nameinttypename,""); 708 } 709 ; 680 710 681 before_function : TOK_FUNCTION { functiondeclarationisdone = 1; } 711 682 ; 712 before_parameter : TOK_PARAMETER { 683 before_parameter : TOK_PARAMETER {VariableIsParameter = 1; pos_curparameter = setposcur()-9; } 713 684 ; 714 685 … … 750 721 ; 751 722 752 save 723 save: before_save varsave 753 724 | before_save comblock varsave 754 725 | save opt_comma comblock opt_comma varsave 755 726 | save ',' varsave 756 727 ; 757 before_save 728 before_save: 758 729 TOK_SAVE { pos_cursave = setposcur()-4; } 759 730 ; … … 896 867 strcpy(curvar->v_subroutinename,subroutinename); 897 868 strcpy(curvar->v_modulename,curmodulename); 898 strcpy(curvar->v_initialvalue,$3);869 curvar->v_initialvalue=Insertname(curvar->v_initialvalue,$3,0); 899 870 strcpy(curvar->v_commoninfile,cur_filename); 900 871 Save_Length($3,14); … … 919 890 } 920 891 } 921 | TOK_IMPLICIT TOK_REAL8 922 ; 923 dcl : options TOK_NAME dims lengspec initial_value 892 ; 893 dcl: options TOK_NAME dims lengspec initial_value 924 894 { 925 895 if ( ! inside_type_declare ) … … 970 940 nodimsgiven : { dimsgiven = 0; } 971 941 ; 972 type : typespec selector { strcpy(DeclType,$1);}942 type: typespec selector { strcpy(DeclType,$1);} 973 943 | before_character c_selector { strcpy(DeclType,"character"); } 974 944 | typespec '*' TOK_CSTINT { strcpy(DeclType,$1); strcpy(nameinttypename,$3); } … … 993 963 | TOK_COMPLEX { strcpy($$,"complex"); pos_cur_decl = setposcur()-7; } 994 964 | TOK_DOUBLECOMPLEX { strcpy($$,"double complex"); pos_cur_decl = setposcur()-14; } 995 | TOK_DOUBLEPRECISION { pos_cur_decl = setposcur()-16; strcpy($$,"real"); strcpy(nameinttypename,"8"); }965 | TOK_DOUBLEPRECISION { pos_cur_decl = setposcur()-16; strcpy($$,"real"); strcpy(nameinttypename,"8"); printf("OK1\n");} 996 966 ; 997 967 lengspec : … … 1033 1003 | ',' TOK_NAME clause 1034 1004 ; 1035 options 1005 options: 1036 1006 | TOK_FOURDOTS 1037 1007 | ',' attr_spec_list TOK_FOURDOTS 1038 1008 ; 1039 attr_spec_list 1009 attr_spec_list: attr_spec 1040 1010 | attr_spec_list ',' attr_spec 1041 1011 ; … … 1047 1017 | TOK_EXTERNAL { ExternalDeclare = 1; } 1048 1018 | TOK_INTENT '(' intent_spec ')' 1049 { strcpy(IntentSpec,$3); }1019 { strcpy(IntentSpec,$3); intent_spec = 0;} 1050 1020 | TOK_INTRINSIC 1051 1021 | TOK_OPTIONAL { optionaldeclare = 1 ; } … … 1064 1034 ; 1065 1035 dims : { $$ = (listdim*) NULL; } 1066 | '(' dimlist ')'1036 | '(' {in_complex_literal=0;} dimlist ')' 1067 1037 { 1068 1038 $$ = (listdim*) NULL; 1069 1039 if ( inside_type_declare ) break; 1070 if ( created_dimensionlist == 1 || agrif_parentcall == 1 ) $$=$ 2;1040 if ( created_dimensionlist == 1 || agrif_parentcall == 1 ) $$=$3; 1071 1041 } 1072 1042 ; … … 1095 1065 | expr { strcpy($$,$1); } 1096 1066 ; 1097 expr : uexpr { strcpy($$,$1); } 1067 /* 1068 expr: uexpr { strcpy($$,$1); } 1098 1069 | complex_const { strcpy($$,$1); } 1099 1070 | predefinedfunction { strcpy($$,$1); } 1100 1071 | '(' expr ')' { sprintf($$,"(%s)",$2); } 1101 1072 ; 1102 1073 */ 1103 1074 predefinedfunction : 1104 1075 TOK_SUM minmaxlist ')' { sprintf($$,"SUM(%s)",$2);} … … 1134 1105 uexpr : lhs { strcpy($$,$1); } 1135 1106 | simple_const { strcpy($$,$1); } 1136 | vec { strcpy($$,$1); }1137 1107 | expr operation { sprintf($$,"%s%s",$1,$2); } 1138 1108 | signe expr %prec '*' { sprintf($$,"%s%s",$1,$2); } … … 1195 1165 begin_array { strcpy($$,$1); if ( incalldeclare == 0 ) inagrifcallargument = 0; } 1196 1166 | begin_array substring { sprintf($$," %s %s ",$1,$2); } 1197 | structure_component '(' funarglist ')' { sprintf($$," %s ( %s )",$1,$3); }1198 | structure_component '(' funarglist ')' substring { sprintf($$," %s ( %s ) %s ",$1,$3,$5); }1199 ; 1200 begin_array : 1201 ident '('funarglist ')'1167 | structure_component '(' {in_complex_literal=0;} funarglist ')' { sprintf($$," %s ( %s )",$1,$4); } 1168 | structure_component '(' {in_complex_literal=0;} funarglist ')' substring { sprintf($$," %s ( %s ) %s ",$1,$4,$6); } 1169 ; 1170 begin_array : TOK_LOGICALIF 1171 | ident '(' {in_complex_literal=0;} funarglist ')' 1202 1172 { 1203 1173 if ( inside_type_declare ) break; 1204 sprintf($$," %s ( %s )",$1,$ 3);1205 ModifyTheAgrifFunction_0($ 3);1174 sprintf($$," %s ( %s )",$1,$4); 1175 ModifyTheAgrifFunction_0($4); 1206 1176 agrif_parentcall = 0; 1207 1177 } … … 1214 1184 } 1215 1185 ; 1186 /* 1216 1187 vec : 1217 1188 TOK_LEFTAB outlist TOK_RIGHTAB { sprintf($$,"(/%s/)",$2); } 1218 1189 ; 1190 */ 1219 1191 funarglist : 1220 1192 beforefunctionuse { strcpy($$," "); } … … 1238 1210 | ':' { sprintf($$,":");} 1239 1211 ; 1240 ident : TOK_NAME 1241 { 1212 ident: TOK_NAME 1213 { 1214 // if (indeclaration == 1) break; 1242 1215 if ( afterpercent == 0 ) 1243 1216 { … … 1303 1276 | substring { strcpy($$,$1);} 1304 1277 ; 1278 /* 1305 1279 substring : 1306 1280 '(' optexpr ':' optexpr ')' { sprintf($$,"(%s :%s)",$2,$4);} 1307 1281 ; 1282 */ 1308 1283 optexpr : { strcpy($$," ");} 1309 1284 | expr { strcpy($$,$1);} 1310 1285 ; 1311 opt_expr : 1312 '\n' { strcpy($$," ");} 1286 opt_expr : { strcpy($$," ");} 1313 1287 | expr { strcpy($$,$1);} 1314 1288 ; 1315 initial_value 1289 initial_value: { InitialValueGiven = 0; } 1316 1290 | '=' expr 1317 1291 { … … 1330 1304 '(' uexpr ',' uexpr ')' {sprintf($$,"(%s,%s)",$2,$4); } 1331 1305 ; 1332 use_stat : 1333 word_use TOK_NAME 1334 { 1335 /* if variables has been declared in a subroutine */ 1336 sprintf(charusemodule, "%s", $2); 1337 if ( firstpass ) 1338 { 1339 Add_NameOfModuleUsed_1($2); 1306 1307 only_list : 1308 only_name { $$ = $1; } 1309 | only_list ',' only_name 1310 { 1311 /* insert the variable in the list $1 */ 1312 $3->suiv = $1; 1313 $$ = $3; 1314 } 1315 ; 1316 only_name : 1317 TOK_NAME TOK_POINT_TO TOK_NAME 1318 { 1319 coupletmp = (listcouple *)calloc(1,sizeof(listcouple)); 1320 strcpy(coupletmp->c_namevar,$1); 1321 strcpy(coupletmp->c_namepointedvar,$3); 1322 coupletmp->suiv = NULL; 1323 $$ = coupletmp; 1324 pointedvar = 1; 1325 Add_UsedInSubroutine_Var_1($1); 1326 } 1327 | TOK_NAME 1328 { 1329 coupletmp = (listcouple *)calloc(1,sizeof(listcouple)); 1330 strcpy(coupletmp->c_namevar,$1); 1331 strcpy(coupletmp->c_namepointedvar,""); 1332 coupletmp->suiv = NULL; 1333 $$ = coupletmp; 1334 } 1335 ; 1336 1337 /* R204 : specification-part */ 1338 /* opt-implicit-part removed but implicit-stmt and format-stmt added to declaration-construct */ 1339 specification-part: opt-use-stmt-list opt-declaration-construct-list 1340 ; 1341 1342 opt-use-stmt-list: 1343 |use-stmt-list 1344 ; 1345 1346 opt-implicit-part: 1347 |implicit-part 1348 ; 1349 1350 implicit-part: opt-implicit-part-stmt-list implicit-stmt 1351 ; 1352 1353 opt-implicit-part-stmt-list: 1354 | implicit-part-stmt-list 1355 ; 1356 1357 implicit-part-stmt-list: implicit-part-stmt 1358 | implicit-part-stmt-list implicit-part-stmt 1359 ; 1360 1361 /* R206: implicit-part-stmt */ 1362 implicit-part-stmt: implicit-stmt 1363 | parameter-stmt 1364 | format-stmt 1365 ; 1366 1367 1368 opt-declaration-construct-list: 1369 |declaration-construct-list 1370 ; 1371 1372 declaration-construct-list: 1373 declaration-construct 1374 | declaration-construct-list declaration-construct 1375 ; 1376 1377 /* R207 : declaration-construct */ 1378 /* stmt-function-stmt replaced by assignment-stmt due to reduce conflicts */ 1379 /* because assignment-stmt has been added */ 1380 /* Every statement that begins with a variable should be added */ 1381 /* This include : */ 1382 /* pointer-assignment-stmt, do-construct */ 1383 /* implicit-stmt and format-stmt added since implicit-part-stmt has been removed due to conflicts (see R204) */ 1384 /* ANOTHER SOLUTION TO THE PROBLEM OF STMT-FUNCTION IS NEEDED !!!! */ 1385 /* BECAUSE ALMOST ALL ACTION-STMT SHOULD BE INCLUDED HERE !!! */ 1386 1387 declaration-construct: derived-type-def 1388 | parameter-stmt 1389 | format-stmt 1390 | implicit-stmt 1391 | other-specification-stmt 1392 | type-declaration-stmt 1393 | assignment-stmt 1394 | pointer-assignment-stmt 1395 | do-construct 1396 | if-construct 1397 | continue-stmt 1398 | return-stmt 1399 | print-stmt 1400 ; 1401 1402 opt-execution-part: 1403 | execution-part 1404 ; 1405 1406 /* R208 : execution-part */ 1407 execution-part: executable-construct opt-execution-part-construct-list 1408 ; 1409 1410 opt-execution-part-construct-list: 1411 |execution-part-construct-list 1412 ; 1413 1414 execution-part-construct-list: 1415 execution-part-construct 1416 | execution-part-construct-list execution-part-construct 1417 ; 1418 1419 /* R209 : execution-part-construct */ 1420 execution-part-construct: executable-construct 1421 | format-stmt 1422 ; 1423 1424 opt-internal-subprogram-part: 1425 | internal-subprogram-part 1426 ; 1427 1428 /* R120 : internal-subprogram-part */ 1429 internal-subprogram-part: TOK_CONTAINS line-break 1430 opt-internal-subprogram 1431 ; 1432 1433 opt-internal-subprogram: 1434 | internal-subprogram-list 1435 ; 1436 1437 internal-subprogram-list: internal-subprogram 1438 | internal-subprogram-list internal-subprogram 1439 ; 1440 1441 /* R211 : internal-subprogram */ 1442 internal-subprogram: function-subprogram 1443 | subroutine-subprogram 1444 ; 1445 1446 /* R212 : other-specification-stmt */ 1447 other-specification-stmt: access-stmt 1448 | common-stmt 1449 | data-stmt 1450 | dimension-stmt 1451 | equivalence-stmt 1452 | external-stmt 1453 | intrinsic-stmt 1454 | namelist-stmt 1455 | save-stmt 1456 ; 1457 1458 /* R213 : executable-construct */ 1459 executable-construct: 1460 action-stmt 1461 | do-construct 1462 | case-construct 1463 | if-construct 1464 | where-construct 1465 ; 1466 1467 /* R214 : action-stmt */ 1468 1469 /* normal action-stmt */ 1470 1471 action-stmt: 1472 allocate-stmt 1473 | assignment-stmt 1474 | call-stmt 1475 | close-stmt 1476 | continue-stmt 1477 | cycle-stmt 1478 | deallocate-stmt 1479 | goto-stmt 1480 | exit-stmt 1481 | flush-stmt 1482 | TOK_CYCLE opt_expr 1483 | TOK_NULLIFY '(' pointer_name_list ')' 1484 | TOK_ENDMODULE opt_name 1485 { 1486 /* if we never meet the contains keyword */ 1487 if ( firstpass == 0 ) 1488 { 1489 RemoveWordCUR_0(fortran_out, strlen($2)+11); // Remove word "end module" 1490 if ( inmoduledeclare && ! aftercontainsdeclare ) 1491 { 1492 Write_Closing_Module(1); 1493 } 1494 fprintf(fortran_out,"\n end module %s\n", curmodulename); 1495 if ( module_declar && insubroutinedeclare == 0 ) 1496 { 1497 fclose(module_declar); 1498 } 1499 } 1500 inmoduledeclare = 0 ; 1501 inmodulemeet = 0 ; 1502 aftercontainsdeclare = 1; 1503 strcpy(curmodulename, ""); 1504 GlobalDeclaration = 0 ; 1505 } 1506 | if-stmt 1507 | inquire-stmt 1508 | open-stmt 1509 | pointer-assignment-stmt 1510 | print-stmt 1511 | read-stmt 1512 | return-stmt 1513 | rewind-stmt 1514 | stop-stmt 1515 | where-stmt 1516 | write-stmt 1517 | arithmetic-if-stmt 1518 ; 1519 1520 /* R215 : keyword */ 1521 keyword: ident 1522 ; 1523 1524 scalar-constant: constant 1525 ; 1526 1527 /* R304 : constant */ 1528 1529 constant: literal-constant 1530 | named-constant 1531 ; 1532 1533 /* R305 : literal-constant */ 1534 literal-constant: int-literal-constant 1535 | real-literal-constant 1536 | logical-literal-constant 1537 | complex-literal-constant 1538 {in_complex_literal=0;} 1539 | char-literal-constant 1540 ; 1541 1542 /* R306 : named-constant */ 1543 named-constant: ident 1544 ; 1545 1546 scalar-int-constant:int-constant 1547 ; 1548 1549 /* R307 : int-constant */ 1550 int-constant: int-literal-constant 1551 | named-constant 1552 ; 1553 1554 /* 1555 constant: TOK_CSTINT 1556 | TOK_CSTREAL 1557 | ident 1558 ; 1559 */ 1560 1561 opt-label: 1562 {strcpy($$,"");} 1563 | label 1564 ; 1565 1566 /* R312 : label */ 1567 label: TOK_LABEL 1568 | TOK_CSTINT 1569 ; 1570 1571 opt-label-djview: 1572 {strcpy($$,"");} 1573 | label-djview 1574 {strcpy($$,$1);} 1575 ; 1576 1577 label-djview: TOK_LABEL_DJVIEW 1578 ; 1579 1580 /* R401 : type-param-value */ 1581 type-param-value: scalar-int-expr 1582 | '*' 1583 | ':' 1584 ; 1585 1586 /* R402: type-spec */ 1587 type-spec: intrinsic-type-spec 1588 {strcpy($$,$1);} 1589 | derived-type-spec 1590 {strcpy($$,$1);} 1591 ; 1592 1593 /* R403 : declaration-type-spec */ 1594 declaration-type-spec: {pos_cur_decl=my_position_before;} intrinsic-type-spec 1595 {strcpy($$,$2);} 1596 | TOK_TYPEPAR intrinsic-type-spec ')' 1597 | TOK_TYPEPAR derived-type-spec ')' 1598 {strcpy(DeclType,"type"); GlobalDeclarationType = 1; } 1599 ; 1600 1601 /* R404 : intrinsic-type-spec */ 1602 intrinsic-type-spec: TOK_INTEGER {in_kind_selector = 1;} opt-kind-selector 1603 {sprintf($$,"%s%s",$1,$[opt-kind-selector]);strcpy(DeclType,$1); in_kind_selector =0;} 1604 | TOK_REAL {in_kind_selector = 1;} opt-kind-selector 1605 {sprintf($$,"%s%s",$1,$[opt-kind-selector]);strcpy(DeclType,$1);in_kind_selector =0;} 1606 | TOK_DOUBLEPRECISION {in_kind_selector = 1;} opt-kind-selector 1607 {sprintf($$,"%s%s",$1,$[opt-kind-selector]);strcpy(DeclType,"real"); strcpy(NamePrecision,"8");in_kind_selector =0;} 1608 | TOK_COMPLEX {in_kind_selector = 1;} opt-kind-selector 1609 {sprintf($$,"%s%s",$1,$[opt-kind-selector]);strcpy(DeclType,$1);in_kind_selector =0;} 1610 | TOK_CHARACTER {in_char_selector = 1;} opt-char-selector 1611 {sprintf($$,"%s%s",$1,$[opt-char-selector]);strcpy(DeclType,$1);in_char_selector = 0;} 1612 | TOK_LOGICAL {in_kind_selector = 1;} opt-kind-selector 1613 {sprintf($$,"%s%s",$1,$[opt-kind-selector]);strcpy(DeclType,$1);in_kind_selector =0;} 1614 ; 1615 1616 opt-kind-selector: 1617 {strcpy($$,"");strcpy(NamePrecision,"");} 1618 |kind-selector 1619 {strcpy($$,$1);} 1620 ; 1621 1622 /* R405 : kind-selector */ 1623 /* Nonstandard extension : * INT */ 1624 kind-selector: '(' scalar-int-constant-expr ')' 1625 {sprintf($$,"(%s)",$2); strcpy(NamePrecision,$2);} 1626 | '(' TOK_KIND '=' scalar-int-constant-expr ')' 1627 {sprintf($$,"(KIND=%s)",$4); strcpy(NamePrecision,$4);} 1628 | '*' TOK_CSTINT 1629 {sprintf($$,"*%s",$2);strcpy(NamePrecision,$2);} 1630 ; 1631 1632 /* R406 : signed-int-literal-constant */ 1633 /* sign replaced by add-op */ 1634 1635 signed-int-literal-constant:int-literal-constant 1636 | add-op int-literal-constant 1637 {sprintf($$,"%s%s",$1,$2);} 1638 ; 1639 1640 /* R407 : int-literal-constant */ 1641 int-literal-constant: TOK_CSTINT 1642 | TOK_CSTINT '_' kind-param 1643 {sprintf($$,"%s_%s",$1,$3);} 1644 ; 1645 1646 /*R408 : kind-param */ 1647 kind-param: TOK_CSTINT 1648 | TOK_NAME 1649 ; 1650 1651 opt-sign: 1652 | sign 1653 ; 1654 1655 /* R411 : sign */ 1656 sign:'+' 1657 {strcpy($$,"+");} 1658 | '-' 1659 {strcpy($$,"-");} 1660 ; 1661 1662 /* R412 : signed-real-literal-constant */ 1663 /* sign replaced by add-op */ 1664 signed-real-literal-constant:real-literal-constant 1665 | add-op real-literal-constant 1666 {sprintf($$,"%s%s",$1,$2);} 1667 ; 1668 1669 /* R413 : real-literal-constant */ 1670 real-literal-constant: TOK_CSTREAL 1671 | TOK_CSTREAL '_' kind-param 1672 {sprintf($$,"%s_%s",$1,$3);}; 1673 ; 1674 1675 /* R417 : complex-literal-constant */ 1676 /* in-complex-literal is just here to change default precedence rules ... */ 1677 1678 complex-literal-constant: '(' real-part TOK_COMMACOMPLEX imag-part ')' 1679 {sprintf($$,"(%s,%s)",$2,$4);} 1680 ; 1681 1682 1683 /* R418 : real-part */ 1684 real-part: signed-int-literal-constant 1685 | signed-real-literal-constant 1686 | ident 1687 ; 1688 1689 /* R419 : imag-part */ 1690 imag-part: signed-int-literal-constant 1691 | signed-real-literal-constant 1692 | named-constant 1693 ; 1694 1695 opt-char_length-star: 1696 | '*' char-length 1697 {char_length_toreset = 1;} 1698 ; 1699 1700 opt-char-selector: 1701 {strcpy($$,"");} 1702 | char-selector 1703 {strcpy($$,"");} 1704 ; 1705 1706 /* R420 : char-selector */ 1707 char-selector:length-selector 1708 | '(' TOK_LEN '=' type-param-value ',' TOK_KIND '=' scalar-int-constant-expr ')' 1709 | '(' type-param-value ',' scalar-int-constant-expr ')' 1710 | '(' TOK_KIND '=' scalar-int-constant-expr ')' 1711 | '(' TOK_KIND '=' scalar-int-constant-expr ',' TOK_LEN '=' type-param-value ')' 1712 ; 1713 1714 /* R421 : length-selector */ 1715 length-selector: '(' type-param-value ')' 1716 {strcpy(CharacterSize,$2);} 1717 | '(' TOK_LEN '=' type-param-value ')' 1718 {strcpy(CharacterSize,$4);} 1719 | '*' char-length 1720 | '*' char-length ',' 1721 ; 1722 1723 /* R422 : char-length */ 1724 char-length: '(' type-param-value ')' 1725 {c_star=1; strcpy(CharacterSize,$2);} 1726 | int-literal-constant 1727 {c_selectorgiven = 1; strcpy(c_selectorname,$1);} 1728 ; 1729 1730 /* R423 : char-literal-constant */ 1731 char-literal-constant: TOK_CHAR_CONSTANT 1732 | TOK_CHAR_MESSAGE 1733 | TOK_CHAR_CUT 1734 ; 1735 1736 /* R424 : logical-literal-constant */ 1737 logical-literal-constant: TOK_TRUE 1738 | TOK_FALSE 1739 ; 1740 1741 /* R425 : derived-type-def */ 1742 derived-type-def: derived-type-stmt { inside_type_declare = 1;} opt-component-part end-type-stmt 1743 { inside_type_declare = 0;} 1744 ; 1745 1746 /* R426 : derived-type-stmt */ 1747 derived-type-stmt: TOK_TYPE opt-type-attr-spec-list-comma-fourdots TOK_NAME line-break 1748 | TOK_TYPE opt-type-attr-spec-list-comma TOK_NAME '(' type-param-name-list ')' line-break 1749 ; 1750 1751 opt-type-attr-spec-list-comma-fourdots: 1752 | opt-type-attr-spec-list-comma TOK_FOURDOTS 1753 ; 1754 1755 opt-type-attr-spec-list-comma: 1756 | ',' type-attr-spec-list 1757 ; 1758 1759 type-attr-spec-list: type-attr-spec 1760 | type-attr-spec-list ',' type-attr-spec 1761 ; 1762 1763 /* R427 : type-attr-spec */ 1764 type-attr-spec: access-spec 1765 ; 1766 1767 type-param-name-list: type-param-name 1768 | type-param-name-list ',' type-param-name 1769 ; 1770 1771 type-param-name: TOK_NAME 1772 ; 1773 1774 /* R429 : end-type-stmt */ 1775 end-type-stmt: TOK_ENDTYPE line-break 1776 | TOK_ENDTYPE TOK_NAME line-break 1777 ; 1778 1779 opt-component-part: 1780 | component-part 1781 ; 1782 1783 /* R434 : component-part */ 1784 component-part: component-def-stmt 1785 | component-part component-def-stmt 1786 ; 1787 1788 /* R435 : component-def-stmt */ 1789 component-def-stmt: data-component-def-stmt 1790 ; 1791 1792 /* R436 : data-component-def-stmt */ 1793 data-component-def-stmt: declaration-type-spec opt-component-attr-spec-list-comma-2points component-decl-list line-break 1794 ; 1795 1796 opt-component-attr-spec-list-comma-2points: 1797 | TOK_FOURDOTS 1798 | ',' component-attr-spec-list TOK_FOURDOTS 1799 ; 1800 1801 component-attr-spec-list: component-attr-spec 1802 | component-attr-spec-list ',' component-attr-spec 1803 ; 1804 1805 /* R437 : component-attr-spec */ 1806 component-attr-spec: access-spec 1807 | TOK_ALLOCATABLE 1808 | TOK_DIMENSION '(' {in_complex_literal=0;} component-array-spec ')' 1809 | TOK_POINTER 1810 ; 1811 1812 component-decl-list: component-decl 1813 | component-decl-list ',' component-decl 1814 ; 1815 1816 /* R438 : component-decl */ 1817 component-decl : ident opt-component-array-spec opt-char_length-star opt-component-initialization 1818 { 1819 PublicDeclare = 0; 1820 PrivateDeclare = 0; 1821 ExternalDeclare = 0; 1822 strcpy(NamePrecision,""); 1823 c_star = 0; 1824 InitialValueGiven = 0 ; 1825 strcpy(IntentSpec,""); 1826 VariableIsParameter = 0 ; 1827 Allocatabledeclare = 0 ; 1828 Targetdeclare = 0 ; 1829 SaveDeclare = 0; 1830 pointerdeclare = 0; 1831 optionaldeclare = 0 ; 1832 dimsgiven=0; 1833 c_selectorgiven=0; 1834 strcpy(nameinttypename,""); 1835 strcpy(c_selectorname,""); 1836 GlobalDeclarationType = 0; 1837 } 1838 ; 1839 1840 opt-component-array-spec: 1841 | '(' component-array-spec ')' 1842 ; 1843 1844 /* R439 : component-array-spec */ 1845 component-array-spec: explicit-shape-spec-list 1846 | deferred-shape-spec-list 1847 ; 1848 1849 opt-component-initialization: 1850 | component-initialization 1851 ; 1852 1853 /* R442 : component-initialization */ 1854 component-initialization: '=' constant-expr 1855 | TOK_POINT_TO null-init 1856 | TOK_POINT_TO initial-data-target 1857 ; 1858 1859 /* R443 initial-data-target */ 1860 initial-data-target: designator 1861 {strcpy(my_dim.last,"");} 1862 ; 1863 1864 /* R453 : derived-type-spec */ 1865 derived-type-spec: ident 1866 {strcpy(NamePrecision,$1);} 1867 | ident '(' type-param-spec-list ')' 1868 ; 1869 1870 type-param-spec-list: type-param-spec 1871 | type-param-spec-list ',' type-param-spec 1872 ; 1873 1874 /* R454 : type-param-spec */ 1875 type-param-spec: type-param-value 1876 | keyword '=' type-param-value 1877 ; 1878 1879 /* R455 : structure-constructor */ 1880 structure-constructor: derived-type-spec '(' ')' 1881 | derived-type-spec '(' component-spec-list ')' 1882 ; 1883 1884 component-spec-list: component-spec 1885 | component-spec-list ',' component-spec 1886 ; 1887 1888 /* R456 : component-spec */ 1889 component-spec: component-data-source 1890 | keyword '=' component-data-source 1891 ; 1892 1893 /* R457 : component-data-source */ 1894 component-data-source: expr 1895 | data-target 1896 | proc-target 1897 ; 1898 1899 /* R468 : array-constructor */ 1900 array-constructor: TOK_LEFTAB ac-spec TOK_RIGHTAB 1901 { sprintf($$,"(/%s/)",$2);} 1902 | lbracket ac-spec rbracket 1903 { sprintf($$,"[%s]",$2); } 1904 ; 1905 1906 /* R469 : ac-spec */ 1907 /* type-spec TOK_FOURDOTS is removed due to conflicts with part-ref */ 1908 1909 /*ac-spec: type-spec TOK_FOURDOTS 1910 {sprintf($$,"%s::",$1);} 1911 | ac-value-list 1912 | type-spec TOK_FOURDOTS ac-value-list 1913 {sprintf($$,"%s::%s",$1,$3);} 1914 ; 1915 */ 1916 1917 ac-spec: ac-value-list 1918 ; 1919 1920 /* R470 : lbracket */ 1921 lbracket: '[' 1922 ; 1923 1924 /* R471 : rbracket */ 1925 rbracket: ']' 1926 ; 1927 1928 ac-value-list: 1929 ac-value 1930 | ac-value-list ',' ac-value 1931 {sprintf($$,"%s,%s",$1,$3);} 1932 ; 1933 1934 /* R472 : ac-value */ 1935 ac-value: expr 1936 | ac-implied-do 1937 ; 1938 1939 /* R473 : ac-implied-do */ 1940 ac-implied-do: '(' ac-value-list ',' ac-implied-do-control ')' 1941 {sprintf($$,"(%s,%s)",$2,$4);} 1942 ; 1943 1944 /* R474 : ac-implied-do-control */ 1945 ac-implied-do-control: ac-do-variable '=' scalar-int-expr ',' scalar-int-expr 1946 {sprintf($$,"%s=%s,%s",$1,$3,$5);} 1947 | ac-do-variable '=' scalar-int-expr ',' scalar-int-expr ',' scalar-int-expr 1948 {sprintf($$,"%s=%s,%s,%s",$1,$3,$5,$7);} 1949 ; 1950 1951 /* R475 : ac-do-variable */ 1952 ac-do-variable: do-variable 1953 ; 1954 1955 /* R501 : type-declaration-stmt */ 1956 type-declaration-stmt: {indeclaration=1;} declaration-type-spec opt-attr-spec-construct entity-decl-list 1957 { 1958 /* if the variable is a parameter we can suppose that is*/ 1959 /* value is the same on each grid. It is not useless */ 1960 /* to create a copy of it on each grid */ 1961 if ( ! inside_type_declare ) 1962 { 1963 pos_end = setposcur(); 1964 //printf("POS = %d %d\n",pos_cur_decl,pos_end); 1965 RemoveWordSET_0(fortran_out,pos_cur_decl,pos_end-pos_cur_decl); 1966 ReWriteDeclarationAndAddTosubroutine_01($[entity-decl-list]); 1967 pos_cur_decl = setposcur(); 1968 if ( firstpass == 0 && GlobalDeclaration == 0 1969 && insubroutinedeclare == 0 ) 1970 { 1971 fprintf(fortran_out,"\n#include \"Module_Declar_%s.h\"\n", curmodulename); 1972 sprintf(ligne, "Module_Declar_%s.h", curmodulename); 1973 module_declar = open_for_write(ligne); 1974 GlobalDeclaration = 1 ; 1975 pos_cur_decl = setposcur(); 1976 } 1977 1978 if ( firstpass ) 1979 { 1980 Add_Globliste_1($[entity-decl-list]); 1981 if ( insubroutinedeclare ) 1982 { 1983 if ( pointerdeclare ) Add_Pointer_Var_From_List_1($[entity-decl-list]); 1984 Add_Parameter_Var_1($[entity-decl-list]); 1985 } 1986 else 1987 Add_GlobalParameter_Var_1($[entity-decl-list]); 1988 1989 /* If there's a SAVE declaration in module's subroutines we should */ 1990 /* remove it from the subroutines declaration and add it in the */ 1991 /* global declarations */ 1992 1993 if ( aftercontainsdeclare && SaveDeclare ) 1994 { 1995 if ( inmodulemeet ) Add_SubroutineDeclarationSave_Var_1($[entity-decl-list]); 1996 else Add_Save_Var_dcl_1($[entity-decl-list]); 1997 } 1998 } 1999 } 2000 indeclaration = 0; 2001 PublicDeclare = 0; 2002 PrivateDeclare = 0; 2003 ExternalDeclare = 0; 2004 strcpy(NamePrecision,""); 2005 c_star = 0; 2006 InitialValueGiven = 0 ; 2007 strcpy(IntentSpec,""); 2008 VariableIsParameter = 0 ; 2009 Allocatabledeclare = 0 ; 2010 Targetdeclare = 0 ; 2011 SaveDeclare = 0; 2012 pointerdeclare = 0; 2013 optionaldeclare = 0 ; 2014 dimsgiven=0; 2015 c_selectorgiven=0; 2016 strcpy(nameinttypename,""); 2017 strcpy(c_selectorname,""); 2018 strcpy(DeclType,""); 2019 GlobalDeclarationType = 0; 2020 } 2021 line-break 2022 ; 2023 2024 opt-attr-spec-construct: 2025 | opt-attr-spec-comma-list TOK_FOURDOTS 2026 ; 2027 2028 opt-attr-spec-comma-list: 2029 | attr-spec-comma-list 2030 ; 2031 2032 attr-spec-comma-list: 2033 ',' attr-spec 2034 | attr-spec-comma-list ',' attr-spec 2035 ; 2036 2037 /* R502 : attr-spec */ 2038 attr-spec:access-spec 2039 | TOK_ALLOCATABLE 2040 { Allocatabledeclare = 1; } 2041 | TOK_DIMENSION '(' {in_complex_literal=0;} array-spec ')' 2042 { dimsgiven = 1; curdim = $4; } 2043 | TOK_EXTERNAL 2044 { ExternalDeclare = 1; } 2045 | TOK_INTENT '(' {in_complex_literal=0;} intent-spec ')' 2046 { strcpy(IntentSpec,$4); } 2047 | TOK_INTRINSIC 2048 | TOK_OPTIONAL 2049 { optionaldeclare = 1 ; } 2050 | TOK_PARAMETER 2051 {VariableIsParameter = 1; } 2052 | TOK_POINTER 2053 { pointerdeclare = 1 ; } 2054 | TOK_SAVE 2055 { SaveDeclare = 1 ; } 2056 | TOK_TARGET 2057 { Targetdeclare = 1; } 2058 ; 2059 2060 2061 entity-decl-list: entity-decl 2062 {$$=insertvar(NULL,$1);} 2063 | entity-decl-list ',' entity-decl 2064 {$$=insertvar($1,$3);} 2065 ; 2066 2067 /* R503 : entity-decl */ 2068 entity-decl: object-name-noident opt-array-spec-par opt-char_length-star opt-initialization 2069 { 2070 if ( ! inside_type_declare ) 2071 { 2072 if (dimsgiven == 1) curvar = createvar($1,curdim); 2073 else curvar = createvar($1,$2); 2074 CreateAndFillin_Curvar(DeclType, curvar); 2075 strcpy(curvar->v_typevar,DeclType); 2076 curvar->v_catvar = get_cat_var(curvar); 2077 2078 if (!strcasecmp(DeclType,"character")) 2079 { 2080 if (c_selectorgiven == 1) 2081 { 2082 Save_Length(c_selectorname,1); 2083 strcpy(curvar->v_dimchar,c_selectorname); 2084 } 2085 } 2086 } 2087 strcpy(vallengspec,""); 2088 if (char_length_toreset == 1) 2089 { 2090 c_selectorgiven = 0; 2091 c_star = 0; 2092 strcpy(c_selectorname,""); 2093 strcpy(CharacterSize,""); 2094 char_length_toreset = 0; 2095 } 2096 $$=curvar; 2097 } 2098 ; 2099 2100 2101 /* R504 : object-name */ 2102 object-name: ident 2103 ; 2104 2105 object-name-noident: TOK_NAME 2106 ; 2107 2108 opt-initialization: {InitialValueGiven = 0; } 2109 | initialization 2110 ; 2111 2112 /* R505 : initialization */ 2113 initialization: '=' constant-expr 2114 { 2115 if ( inside_type_declare ) break; 2116 strcpy(InitValue,$2); 2117 InitialValueGiven = 1; 2118 } 2119 | TOK_POINT_TO null-init 2120 { 2121 if ( inside_type_declare ) break; 2122 strcpy(InitValue,$2); 2123 InitialValueGiven = 2; 2124 } 2125 | TOK_POINT_TO initial-data-target 2126 { 2127 if ( inside_type_declare ) break; 2128 strcpy(InitValue,$2); 2129 InitialValueGiven = 2; 2130 } 2131 ; 2132 2133 /* R506 : null-init */ 2134 null-init: function-reference 2135 ; 2136 2137 /* R507 : access-spec */ 2138 access-spec: TOK_PUBLIC 2139 {PublicDeclare = 1; } 2140 | TOK_PRIVATE 2141 {PrivateDeclare = 1; } 2142 ; 2143 2144 opt-array-spec-par: 2145 {$$=NULL;} 2146 | '(' {in_complex_literal=0;} array-spec ')' 2147 {$$=$3;} 2148 ; 2149 2150 /* R514 : array-spec */ 2151 array-spec: explicit-shape-spec-list 2152 {$$=$1;} 2153 | assumed-shape-spec-list 2154 {$$=$1;} 2155 | deferred-shape-spec-list 2156 {$$=$1;} 2157 | assumed-size-spec 2158 {$$=$1;} 2159 | implied-shape-spec-list 2160 {$$=$1;} 2161 ; 2162 2163 explicit-shape-spec-list: explicit-shape-spec 2164 { 2165 $$ = (listdim*) NULL; 2166 if ( inside_type_declare ) break; 2167 if ( created_dimensionlist == 1 || agrif_parentcall == 1 ) $$=insertdim(NULL,$1); 2168 } 2169 | explicit-shape-spec-list ',' explicit-shape-spec 2170 { 2171 $$ = (listdim*) NULL; 2172 if ( inside_type_declare ) break; 2173 if ( (!inside_type_declare) && created_dimensionlist == 1 ) $$=insertdim($1,$3); 2174 } 2175 ; 2176 2177 /* R516 : explicit-shape-spec */ 2178 explicit-shape-spec: lower-bound ':' upper-bound 2179 {strcpy($$.first,$1); Save_Length($1,2); strcpy($$.last,$3); Save_Length($3,1); } 2180 |upper-bound 2181 {strcpy($$.first,"1"); strcpy($$.last,$1); Save_Length($1,1);} 2182 ; 2183 2184 /* R517 : lower-bound */ 2185 lower-bound: specification-expr 2186 {strcpy($$,$1);} 2187 ; 2188 2189 /* R518 : upper-bound */ 2190 upper-bound: specification-expr 2191 ; 2192 2193 assumed-shape-spec-list: 2194 assumed-shape-spec 2195 { 2196 $$ = (listdim*) NULL; 2197 if ( inside_type_declare ) break; 2198 if ( created_dimensionlist == 1 || agrif_parentcall == 1 ) $$=insertdim(NULL,$1); 2199 } 2200 | assumed-shape-spec-list ',' assumed-shape-spec 2201 { 2202 $$ = (listdim*) NULL; 2203 if ( inside_type_declare ) break; 2204 if ( (!inside_type_declare) && created_dimensionlist == 1 ) $$=insertdim($1,$3); 2205 } 2206 ; 2207 2208 /* R519 : assumed-shape-spec */ 2209 assumed-shape-spec : ':' 2210 { strcpy($$.first,""); strcpy($$.last,""); } 2211 | lower-bound ':' 2212 { strcpy($$.first,$1); Save_Length($1,2); strcpy($$.last,""); } 2213 ; 2214 2215 deferred-shape-spec-list: 2216 deferred-shape-spec 2217 { 2218 $$ = (listdim*) NULL; 2219 if ( inside_type_declare ) break; 2220 if ( created_dimensionlist == 1 || agrif_parentcall == 1 ) $$=insertdim(NULL,$1); 2221 } 2222 | deferred-shape-spec-list ',' deferred-shape-spec 2223 { 2224 $$ = (listdim*) NULL; 2225 if ( inside_type_declare ) break; 2226 if ( (!inside_type_declare) && created_dimensionlist == 1 ) $$=insertdim($1,$3); 2227 } 2228 ; 2229 2230 /* R520 : deferred-shape-spec */ 2231 deferred-shape-spec: ':' 2232 { strcpy($$.first,""); strcpy($$.last,""); } 2233 ; 2234 2235 /* R521 : assume-size-spec */ 2236 assumed-size-spec:opt-explicit-shape-spec-list-comma opt-lower-bound-2points '*' 2237 { 2238 $$ = (listdim*) NULL; 2239 if ( inside_type_declare ) break; 2240 if ( created_dimensionlist == 1 || agrif_parentcall == 1 ) 2241 { 2242 if (!strcasecmp($2,"")) 2243 { 2244 strcpy(my_dim.first,"1"); 1340 2245 } 1341 2246 else 1342 2247 { 1343 if ( insubroutinedeclare ) 1344 copyuse_0($2); 1345 1346 if ( inmoduledeclare == 0 ) 2248 strcpy(my_dim.first,$2); 2249 } 2250 strcpy(my_dim.last,"*"); 2251 $$=insertdim($1,my_dim); 2252 strcpy(my_dim.first,""); 2253 strcpy(my_dim.last,""); 2254 } 2255 } 2256 ; 2257 2258 opt-explicit-shape-spec-list-comma: 2259 {$$ = (listdim *) NULL;} 2260 | explicit-shape-spec-list ',' 2261 {$$ = $1;} 2262 ; 2263 2264 explicit-shape-spec-list-comma: explicit-shape-spec ',' 2265 { 2266 $$ = (listdim*) NULL; 2267 if ( inside_type_declare ) break; 2268 if ( created_dimensionlist == 1 || agrif_parentcall == 1 ) $$=insertdim(NULL,$1); 2269 } 2270 | explicit-shape-spec-list-comma explicit-shape-spec ',' 2271 { 2272 $$ = (listdim*) NULL; 2273 if ( inside_type_declare ) break; 2274 if ( (!inside_type_declare) && created_dimensionlist == 1 ) $$=insertdim($1,$2); 2275 } 2276 ; 2277 2278 opt-lower-bound-2points: 2279 {strcpy($$,"");} 2280 | lower-bound ':' 2281 {strcpy($$,$1);} 2282 ; 2283 2284 implied-shape-spec-list: implied-shape-spec 2285 | implied-shape-spec-list ',' implied-shape-spec 2286 ; 2287 2288 /* R522 : implied-shape-spec */ 2289 implied-shape-spec: opt-lower-bound-2points '*' 2290 ; 2291 2292 /* R523 : intent-spec */ 2293 intent-spec: TOK_IN 2294 { strcpy($$,$1); } 2295 | TOK_OUT 2296 { strcpy($$,$1); } 2297 | TOK_INOUT 2298 { strcpy($$,$1); } 2299 ; 2300 2301 /* R524 : access-stmt */ 2302 access-stmt: access-spec opt-access-id-list 2303 { 2304 if ((firstpass == 0) && (PublicDeclare == 1)) 2305 { 2306 if ($2) 2307 { 2308 removeglobfromlist(&($2)); 2309 pos_end = setposcur(); 2310 RemoveWordSET_0(fortran_out,pos_cur,pos_end-pos_cur); 2311 writelistpublic($2); 2312 } 2313 } 2314 PublicDeclare = 0; 2315 PrivateDeclare = 0; 2316 } 2317 line-break 2318 ; 2319 2320 opt-access-id-list: 2321 {$$=(listname *)NULL;} 2322 | opt-TOK_FOURDOTS access-id-list 2323 {$$=$2;} 2324 ; 2325 2326 access-id-list: access-id 2327 {$$=Insertname(NULL,$1,0);} 2328 | access-id-list ',' access-id 2329 {$$=Insertname($1,$3,0);} 2330 ; 2331 2332 /* R525 : access-id */ 2333 access-id: TOK_NAME 2334 | generic-spec 2335 ; 2336 2337 /* R534 : data-stmt */ 2338 data-stmt: TOK_DATA data-stmt-set opt-data-stmt-set-nlist 2339 { 2340 /* we should remove the data declaration */ 2341 pos_end = setposcur(); 2342 RemoveWordSET_0(fortran_out,pos_curdata,pos_end-pos_curdata); 2343 if ( aftercontainsdeclare == 1 && firstpass == 0 ) 2344 { 2345 ReWriteDataStatement_0(fortran_out); 2346 pos_end = setposcur(); 2347 } 2348 Init_List_Data_Var(); 2349 } 2350 line-break 2351 ; 2352 2353 opt-data-stmt-set-nlist: 2354 | data-stmt-set-nlist 2355 ; 2356 2357 data-stmt-set-nlist: opt-comma data-stmt-set 2358 | data-stmt-set-nlist opt-comma data-stmt-set 2359 ; 2360 2361 /* R535 : data-stmt-set */ 2362 data-stmt-set: data-stmt-object-list TOK_SLASH data-stmt-value-list TOK_SLASH 2363 { 2364 if (firstpass == 1) 2365 { 2366 Add_Data_Var_Names_01(&List_Data_Var,$1,$3); 2367 } 2368 else Add_Data_Var_Names_01(&List_Data_Var_Cur,$1,$3); 2369 } 2370 ; 2371 2372 data-stmt-object-list: data-stmt-object 2373 { $$=insertvar(NULL,$1); } 2374 | data-stmt-object-list ',' data-stmt-object 2375 { 2376 $$ = insertvar($1,$3); 2377 } 2378 ; 2379 2380 data-stmt-value-list: data-stmt-value 2381 {$$=Insertname(NULL,$1,0);} 2382 | data-stmt-value-list ',' data-stmt-value 2383 {$$ = Insertname($1,$3,1); } 2384 ; 2385 2386 /* R536 : data-stmt-object */ 2387 data-stmt-object: variable 2388 | data-implied-do 2389 ; 2390 2391 /* R537 : data-implied-do */ 2392 data-implied-do: '(' data-i-do-object-list ',' data-i-do-variable '=' scalar-int-constant-expr ',' scalar-int-constant-expr ')' 2393 {printf("DOVARIABLE = %s %s %s\n",$4,$6,$8); 2394 printf("AUTRE = %s %s\n",$2->var->v_nomvar,$2->var->v_initialvalue_array); 2395 Insertdoloop($2->var,$4,$6,$8,""); 2396 $$=$2->var; 2397 } 2398 | '(' data-i-do-object-list ',' data-i-do-variable '=' scalar-int-constant-expr ',' scalar-int-constant-expr ',' scalar-int-constant-expr ')' 2399 { 2400 Insertdoloop($2->var,$4,$6,$8,$10); 2401 $$=$2->var; 2402 } 2403 ; 2404 2405 data-i-do-object-list: data-i-do-object 2406 {$$=insertvar(NULL,$1);} 2407 | data-i-do-object-list ',' data-i-do-object 2408 {$$ = insertvar($1,$3);} 2409 ; 2410 2411 /* R538 : data-i-do-object */ 2412 data-i-do-object: array-element 2413 | scalar-structure-component 2414 {$$->v_initialvalue_array=Insertname($$->v_initialvalue_array,my_dim.last,0); 2415 strcpy(my_dim.last,""); 2416 } 2417 | data-implied-do 2418 ; 2419 2420 /* R539 : data-i-do-variable */ 2421 data-i-do-variable: do-variable 2422 ; 2423 2424 /* R540 : data-stmt-value */ 2425 /* data-stmt-repeat and first data-stmt-constant inlined */ 2426 data-stmt-value: scalar-constant-subobject opt-data-stmt-star 2427 {sprintf($$,"%s%s",$1,$2);} 2428 | int-literal-constant opt-data-stmt-star 2429 {sprintf($$,"%s%s",$1,$2);} 2430 | char-literal-constant opt-data-stmt-star 2431 {sprintf($$,"%s%s",$1,$2);} 2432 | signed-int-literal-constant 2433 | signed-real-literal-constant 2434 | null-init 2435 | initial-data-target 2436 | structure-constructor 2437 ; 2438 2439 opt-data-stmt-star: 2440 {strcpy($$,"");} 2441 | '*' data-stmt-constant 2442 {sprintf($$,"*%s",$2);} 2443 ; 2444 2445 opt-data-stmt-repeat-star: 2446 | data-stmt-repeat '*' 2447 ; 2448 2449 /* R541 : data-stmt-repeat */ 2450 /* scalar-int-constant inlined */ 2451 2452 data-stmt-repeat: scalar-int-constant 2453 | scalar-int-constant-subobject 2454 ; 2455 2456 /* R542 : data-stmt-constant */ 2457 data-stmt-constant: scalar-constant 2458 | scalar-constant-subobject 2459 | signed-int-literal-constant 2460 | signed-real-literal-constant 2461 | null-init 2462 | initial-data-target 2463 | structure-constructor 2464 ; 2465 2466 scalar-int-constant-subobject: int-constant-subobject 2467 ; 2468 2469 scalar-constant-subobject: constant-subobject 2470 ; 2471 2472 /* R543 : int-constant-subobject */ 2473 int-constant-subobject: constant-subobject 2474 ; 2475 2476 /* R544 : constant-subobject */ 2477 constant-subobject: designator 2478 {strcpy(my_dim.last,"");} 2479 ; 2480 2481 /* R545 : dimension-stmt */ 2482 dimension-stmt: {positioninblock = 0; pos_curdimension = my_position_before;} 2483 TOK_DIMENSION opt-TOK_FOURDOTS array-name-spec-list 2484 { 2485 /* if the variable is a parameter we can suppose that is */ 2486 /* value is the same on each grid. It is not useless to */ 2487 /* create a copy of it on each grid */ 2488 if ( ! inside_type_declare ) 2489 { 2490 if ( firstpass ) 2491 { 2492 Add_Globliste_1($4); 2493 /* if variableparamlists has been declared in a subroutine */ 2494 if ( insubroutinedeclare ) Add_Dimension_Var_1($4); 2495 2496 /* Add it to the List_SubroutineDeclaration_Var list if not present */ 2497 /* NB: if not done, a variable declared with DIMENSION but with no type given */ 2498 /* will not be declared by the conv */ 2499 ReWriteDeclarationAndAddTosubroutine_01($4); 2500 } 2501 else 1347 2502 { 1348 2503 pos_end = setposcur(); 1349 RemoveWordSET_0(fortran_out,pos_curuse,pos_end-pos_curuse); 2504 RemoveWordSET_0(fortran_out,pos_curdimension,pos_end-pos_curdimension); 2505 ReWriteDeclarationAndAddTosubroutine_01($4); 1350 2506 } 1351 2507 } 1352 } 1353 | word_use TOK_NAME ',' rename_list 1354 { 2508 PublicDeclare = 0; 2509 PrivateDeclare = 0; 2510 ExternalDeclare = 0; 2511 strcpy(NamePrecision,""); 2512 c_star = 0; 2513 InitialValueGiven = 0 ; 2514 strcpy(IntentSpec,""); 2515 VariableIsParameter = 0 ; 2516 Allocatabledeclare = 0 ; 2517 Targetdeclare = 0 ; 2518 SaveDeclare = 0; 2519 pointerdeclare = 0; 2520 optionaldeclare = 0 ; 2521 dimsgiven=0; 2522 c_selectorgiven=0; 2523 strcpy(nameinttypename,""); 2524 strcpy(c_selectorname,""); 2525 } 2526 line-break 2527 ; 2528 2529 array-name-spec-list: TOK_NAME '(' {in_complex_literal = 0;} array-spec ')' 2530 { 2531 if ( inside_type_declare ) break; 2532 curvar = createvar($1,$4); 2533 CreateAndFillin_Curvar("", curvar); 2534 curlistvar=insertvar(NULL, curvar); 2535 $$ = settype("",curlistvar); 2536 strcpy(vallengspec,""); 2537 } 2538 | array-name-spec-list ',' TOK_NAME '(' {in_complex_literal = 0;} array-spec ')' 2539 { 2540 if ( inside_type_declare ) break; 2541 curvar = createvar($3,$6); 2542 CreateAndFillin_Curvar("", curvar); 2543 curlistvar = insertvar($1, curvar); 2544 $$ = curlistvar; 2545 strcpy(vallengspec,""); 2546 } 2547 ; 2548 2549 2550 /* R548 : parameter-stmt */ 2551 parameter-stmt: TOK_PARAMETER { VariableIsParameter = 1; pos_curparameter = setposcur()-9; } '(' named-constant-def-list ')' 2552 { 2553 if ( ! inside_type_declare ) 2554 { 2555 if ( firstpass ) 2556 { 2557 if ( insubroutinedeclare ) Add_Parameter_Var_1($4); 2558 else Add_GlobalParameter_Var_1($4); 2559 } 2560 else 2561 { 2562 pos_end = setposcur(); 2563 RemoveWordSET_0(fortran_out, pos_curparameter, pos_end-pos_curparameter); 2564 } 2565 } 2566 VariableIsParameter = 0 ; 2567 } 2568 line-break 2569 ; 2570 2571 named-constant-def-list: named-constant-def 2572 {$$=insertvar(NULL,$1);} 2573 | named-constant-def-list ',' named-constant-def 2574 {$$=insertvar($1,$3);} 2575 ; 2576 2577 /* R549 : named-constant-def */ 2578 named-constant-def: TOK_NAME '=' constant-expr 2579 { 2580 if ( inside_type_declare ) break; 2581 curvar=(variable *) calloc(1,sizeof(variable)); 2582 Init_Variable(curvar); 2583 curvar->v_VariableIsParameter = 1; 2584 strcpy(curvar->v_nomvar,$1); 2585 strcpy(curvar->v_subroutinename,subroutinename); 2586 strcpy(curvar->v_modulename,curmodulename); 2587 curvar->v_initialvalue=Insertname(curvar->v_initialvalue,$3,0); 2588 strcpy(curvar->v_commoninfile,cur_filename); 2589 Save_Length($3,14); 2590 $$ = curvar; 2591 } 2592 ; 2593 2594 /* R553 : save-stmt */ 2595 save-stmt: {pos_cursave = my_position_before;} TOK_SAVE opt-TOK_FOURDOTS opt-saved-entity-list 2596 { 2597 pos_end = setposcur(); 2598 RemoveWordSET_0(fortran_out,pos_cursave,pos_end-pos_cursave); 2599 } 2600 line-break 2601 ; 2602 2603 opt-TOK_FOURDOTS: 2604 | TOK_FOURDOTS 2605 ; 2606 2607 opt-saved-entity-list: 2608 | saved-entity-list 2609 ; 2610 2611 saved-entity-list: saved-entity 2612 | saved-entity-list ',' saved-entity 2613 ; 2614 2615 /* R554 : saved-entity */ 2616 saved-entity: object-name 2617 {if ( ! inside_type_declare ) Add_Save_Var_1($1,(listdim*) NULL); } 2618 | proc-pointer-name 2619 | common-block-name 2620 ; 2621 2622 /* R555 : proc-pointer-name */ 2623 proc-pointer-name: ident 2624 ; 2625 2626 get_my_position: 2627 {my_position = my_position_before;} 2628 ; 2629 2630 /* R560 : implicit-stmt */ 2631 implicit-stmt: get_my_position TOK_IMPLICIT implicit-spec-list line-break 2632 | get_my_position TOK_IMPLICIT TOK_NONE 2633 { 2634 if ( insubroutinedeclare == 1 ) 2635 { 2636 Add_ImplicitNoneSubroutine_1(); 2637 pos_end = setposcur(); 2638 RemoveWordSET_0(fortran_out,my_position,pos_end-my_position); 2639 } 2640 } 2641 line-break 2642 ; 2643 2644 implicit-spec-list: implicit-spec 2645 | implicit-spec-list ',' implicit-spec 2646 ; 2647 2648 /*R561 implicit-spec */ 2649 implicit-spec: declaration-type-spec '(' letter-spec-list ')' 2650 ; 2651 2652 letter-spec-list:letter-spec 2653 | letter-spec-list ',' letter-spec 2654 ; 2655 2656 /* R562 : letter-spec */ 2657 letter-spec: TOK_NAME 2658 | TOK_NAME '-' TOK_NAME 2659 ; 2660 2661 /* R563 : namelist-stmt */ 2662 namelist-stmt: TOK_NAMELIST TOK_SLASH TOK_NAME TOK_SLASH namelist-group-object-list opt-namelist-other line-break 2663 ; 2664 2665 opt-namelist-other: 2666 | opt-namelist-other opt-comma TOK_SLASH TOK_NAME TOK_SLASH namelist-group-object-list 2667 2668 namelist-group-object-list:namelist-group-object 2669 | namelist-group-object-list ',' namelist-group-object 2670 ; 2671 2672 /* R564 : namelist-group-object */ 2673 namelist-group-object: variable-name 2674 ; 2675 2676 /* R565 : equivalence-stmt */ 2677 equivalence-stmt: TOK_EQUIVALENCE equivalence-set-list line-break 2678 ; 2679 2680 equivalence-set-list:equivalence-set 2681 | equivalence-set-list ',' equivalence-set 2682 ; 2683 2684 /* R566 : equivalence-set */ 2685 equivalence-set: '(' {in_complex_literal=0;} equivalence-object ',' equivalence-object-list ')' 2686 ; 2687 2688 equivalence-object-list:equivalence-object 2689 | equivalence-object-list ',' equivalence-object 2690 ; 2691 2692 /* R567 : equivalence-object */ 2693 equivalence-object: variable-name 2694 | array-element 2695 | substring 2696 ; 2697 2698 2699 /* R568 : common-stmt */ 2700 common-stmt: TOK_COMMON { positioninblock = 0; pos_curcommon = my_position_before; indeclaration=1;} opt-common-block-name common-block-object-list opt-common-block-list 2701 { 2702 indeclaration = 0; 2703 if ( inside_type_declare ) break; 2704 pos_end = setposcur(); 2705 RemoveWordSET_0(fortran_out,pos_curcommon,pos_end-pos_curcommon); 2706 } 2707 line-break 2708 ; 2709 2710 opt-common-block-name: 2711 | common-block-name 2712 { 2713 if ( inside_type_declare ) break; 2714 sprintf(charusemodule,"%s",$1); 2715 Add_NameOfCommon_1($1,subroutinename); 2716 } 2717 ; 2718 2719 common-block-name:TOK_DSLASH 2720 { 2721 strcpy($$,""); 2722 positioninblock=0; 2723 strcpy(commonblockname,""); 2724 } 2725 | TOK_SLASH TOK_NAME TOK_SLASH 2726 { 2727 strcpy($$,$2); 2728 positioninblock=0; 2729 strcpy(commonblockname,$2); 2730 } 2731 ; 2732 2733 opt-comma: 2734 | ',' 2735 ; 2736 2737 opt-common-block-list: 2738 | opt-common-block-list opt-comma common-block-name 2739 { 2740 if ( inside_type_declare ) break; 2741 sprintf(charusemodule,"%s",$3); 2742 Add_NameOfCommon_1($3,subroutinename); 2743 } 2744 common-block-object-list 2745 ; 2746 2747 2748 common-block-object-list: common-block-object 2749 {if ( ! inside_type_declare ) Add_Common_var_1(); } 2750 | common-block-object-list ',' common-block-object 2751 {if ( ! inside_type_declare ) Add_Common_var_1(); } 2752 ; 2753 2754 /* R569 : common-block-object */ 2755 /* variable-name replaced by TOK_NAME */ 2756 /* because the corresponding variable do not have to be added to the listofsubroutine_used */ 2757 2758 common-block-object: TOK_NAME 2759 { 2760 positioninblock = positioninblock + 1 ; 2761 strcpy(commonvar,$1); 2762 commondim = (listdim*) NULL; 2763 } 2764 | TOK_NAME '(' {in_complex_literal=0;} array-spec ')' 2765 { 2766 positioninblock = positioninblock + 1 ; 2767 strcpy(commonvar,$1); 2768 commondim = $4; 2769 } 2770 ; 2771 2772 /* R601 : designator */ 2773 designator: array-element 2774 | array-section 2775 | structure-component 2776 | substring 2777 {$$=createvar($1,NULL);} 2778 ; 2779 /* R602 : variable */ 2780 /*variable: designator 2781 | expr 2782 ; 2783 */ 2784 2785 scalar-variable: variable 2786 ; 2787 2788 variable: designator 2789 {if (strcmp(my_dim.last,"")) 2790 { 2791 $$->v_initialvalue_array=Insertname(NULL,my_dim.last,0); 2792 } 2793 strcpy(my_dim.last,""); 2794 } 2795 ; 2796 2797 scalar-variable-name: variable-name 2798 ; 2799 2800 /* R603 : variable-name */ 2801 variable-name: ident 2802 ; 2803 2804 scalar-logical-variable: logical-variable 2805 ; 2806 2807 /* R604 : logical-variable */ 2808 logical-variable: variable 2809 ; 2810 2811 /* R605 : char-variable */ 2812 char-variable: variable 2813 ; 2814 2815 scalar-default-char-variable: default-char-variable 2816 ; 2817 2818 /* R606 : default-char-variable */ 2819 default-char-variable: variable 2820 ; 2821 2822 scalar-int-variable: int-variable 2823 ; 2824 2825 int-variable: variable 2826 ; 2827 2828 /* R608 : substring */ 2829 substring: data-ref 2830 | data-ref '(' substring-range ')' 2831 {sprintf($$,"%s(%s)",$1,$3);} 2832 | char-literal-constant '(' substring-range ')' 2833 {sprintf($$,"%s(%s)",$1,$3);} 2834 ; 2835 2836 /* R609 : parent-string */ 2837 /* IS INLINED IN SUBSTRING (R608) */ 2838 /* 2839 parent-string: scalar-variable-name 2840 | array-element 2841 | scalar-structure-component 2842 | scalar-constant 2843 ; 2844 */ 2845 2846 /* R610 : substring-range */ 2847 substring-range: opt-scalar-int-expr ':' opt-scalar-int-expr 2848 {sprintf($$,"%s:%s",$1,$3);} 2849 ; 2850 2851 /* R611: data-ref */ 2852 data-ref: part-ref opt-part-ref 2853 {sprintf($$,"%s%s",$1->v_nomvar,$2);} 2854 ; 2855 2856 opt-part-ref: 2857 {strcpy($$,"");} 2858 | opt-part-ref '%' part-ref 2859 {sprintf($$,"%s%%%s",$1,$3->v_nomvar);} 2860 ; 2861 2862 /* R612 : part-ref */ 2863 part-ref:ident 2864 {$$=createvar($1,NULL);} 2865 | ident '(' {in_complex_literal=0;} section-subscript-list ')' 2866 {sprintf(ligne,"%s(%s)",$1,$4);$$=createvar($1,NULL);strcpy(my_dim.last,$4);} 2867 ; 2868 2869 /* $$=createvar($1,insertdim(NULL,my_dim)); 2870 {strcpy(my_dim.first,"1");strcpy(my_dim.last,$4);$$=createvar($1,insertdim(NULL,my_dim));} 2871 } */ 2872 2873 /*part-name: ident 2874 ; 2875 */ 2876 2877 scalar-structure-component: structure-component 2878 ; 2879 2880 /* R613 : structure-component */ 2881 structure-component: data-ref 2882 {strcpy(my_dim.last,"");} 2883 ; 2884 2885 /* R617 : array-element */ 2886 array-element: data-ref 2887 {strcpy(my_dim.last,"");} 2888 ; 2889 2890 /* R618 : array-section */ 2891 array-section: data-ref 2892 {strcpy(my_dim.last,"");} 2893 | data-ref '(' substring-range ')' 2894 {strcpy(my_dim.last,"");} 2895 ; 2896 2897 /* section-subscript-list can be empty ... */ 2898 /* in contradiction with the grammar ... */ 2899 section-subscript-list: 2900 {strcpy($$,"");} 2901 | section-subscript 2902 {strcpy($$,$1);} 2903 | section-subscript-list ',' section-subscript 2904 {sprintf($$,"%s,%s",$1,$3);} 2905 ; 2906 2907 opt-subscript: 2908 {strcpy($$,"");} 2909 | subscript 2910 ; 2911 2912 /* R619 : subscript */ 2913 subscript: scalar-int-expr 2914 ; 2915 2916 /* R620 : section-subscript */ 2917 /*section-subscript: subscript 2918 | subscript-triplet 2919 | vector-subscript 2920 ; 2921 */ 2922 2923 /* USE OpenFortranParser rules */ 2924 2925 section-subscript: expr section_subscript_ambiguous 2926 {sprintf($$,"%s%s",$1,$2);} 2927 | ':' 2928 {strcpy($$,":");} 2929 | ':' expr 2930 {sprintf($$,":%s",$2);} 2931 | ':' ':' expr 2932 {sprintf($$,": :%s",$3);} 2933 | ':' expr ':' expr 2934 {sprintf($$,":%s :%s",$2,$4);} 2935 | TOK_FOURDOTS expr 2936 {sprintf($$,"::%s",$2);} 2937 | vector-subscript 2938 | ident '=' expr 2939 {sprintf($$,"%s=%s",$1,$3);} 2940 | ident '=' '*' label 2941 {sprintf($$,"%s=*%s",$1,$4);} 2942 | '*' label 2943 {sprintf($$,"*%s",$2);} 2944 ; 2945 2946 section_subscript_ambiguous: ':' 2947 {strcpy($$,":");} 2948 | ':' expr 2949 {sprintf($$,":%s",$2);} 2950 | ':' ':' expr 2951 {sprintf($$,": :%s",$3);} 2952 | ':' expr ':' expr 2953 {sprintf($$,":%s :%s",$2,$4);} 2954 | TOK_FOURDOTS expr 2955 {sprintf($$,"::%s",$2);} 2956 | 2957 {strcpy($$,"");} 2958 ; 2959 /* R621 : subscript-triplet */ 2960 subscript-triplet: opt-subscript ':' opt-subscript 2961 {sprintf($$,"%s:%s",$1,$3);} 2962 | opt-subscript ':' opt-subscript ':' stride 2963 {sprintf($$,"%s:%s:%s",$1,$3,$5);} 2964 ; 2965 2966 /* R622 : stride */ 2967 stride: scalar-int-expr 2968 ; 2969 2970 /* R623 : vector-subscript */ 2971 vector-subscript: int-expr 2972 ; 2973 2974 /* R626 : allocate-stmt */ 2975 allocate-stmt: TOK_ALLOCATE '(' {in_complex_literal=0;} allocation-list opt-alloc-opt-list-comma ')' 2976 {inallocate = 0;} 2977 line-break 2978 ; 2979 2980 opt-type-spec-fourdots: 2981 | type-spec TOK_FOURDOTS 2982 ; 2983 2984 opt-alloc-opt-list-comma: 2985 | ',' alloc-opt-list 2986 ; 2987 2988 alloc-opt-list: 2989 alloc-opt 2990 | alloc-opt-list ',' alloc-opt 2991 ; 2992 2993 /* R627 : alloc-opt */ 2994 alloc-opt: TOK_ERRMSG errmsg-variable 2995 | TOK_STAT '=' stat-variable 2996 ; 2997 2998 /* R628 : stat-variable */ 2999 stat-variable: scalar-int-variable 3000 ; 3001 3002 /* R629 : errmsg-variable */ 3003 errmsg-variable: scalar-default-char-variable 3004 ; 3005 3006 allocation-list: 3007 allocation 3008 | allocation-list ',' allocation 3009 ; 3010 3011 /* R631 allocation */ 3012 allocation: allocate-object opt-allocate-shape-spec-list-par 3013 ; 3014 3015 /* R632 allocate-object */ 3016 allocate-object: variable-name 3017 | structure-component 3018 ; 3019 3020 opt-allocate-shape-spec-list-par: 3021 | '(' allocate-shape-spec-list ')' 3022 ; 3023 3024 allocate-shape-spec-list: 3025 allocate-shape-spec 3026 | allocate-shape-spec-list ',' allocate-shape-spec 3027 ; 3028 3029 /* R633 : allocate-shape-spec */ 3030 allocate-shape-spec: opt-lower-bound-expr upper-bound-expr 3031 ; 3032 3033 opt-lower-bound-expr: 3034 | lower-bound-expr ':' 3035 ; 3036 3037 /* R634 : lower-bound-expr */ 3038 lower-bound-expr: scalar-int-expr 3039 ; 3040 3041 /* R634 : upper-bound-expr */ 3042 upper-bound-expr: scalar-int-expr 3043 ; 3044 3045 /* R640 : deallocate-stmt */ 3046 deallocate-stmt: TOK_DEALLOCATE '(' {in_complex_literal=0;} allocate-object-list opt-dealloc-opt-list-comma ')' 3047 {inallocate = 0;} 3048 line-break 3049 ; 3050 3051 allocate-object-list: 3052 allocate-object 3053 | allocate-object-list ',' allocate-object 3054 ; 3055 3056 opt-dealloc-opt-list-comma: 3057 | ',' dealloc-opt-list 3058 ; 3059 3060 dealloc-opt-list: 3061 dealloc-opt 3062 | dealloc-opt-list ',' dealloc-opt 3063 ; 3064 3065 /* R641 : dealloc-opt */ 3066 dealloc-opt: TOK_ERRMSG errmsg-variable 3067 | TOK_STAT '=' stat-variable 3068 ; 3069 3070 /* R701 : primary */ 3071 /* remove type-param-name */ 3072 /* constant replaced by literal-constant to avoid conflict with designato */ 3073 /* real-part is added because potential conflicts with complex-literal-constant */ 3074 3075 primary: 3076 designator 3077 { 3078 strcpy($$,$1->v_nomvar); 3079 if (strcasecmp(my_dim.last,"")) 3080 { 3081 strcat($$,"("); 3082 strcat($$,my_dim.last); 3083 strcat($$,")"); 3084 } 3085 } 3086 | literal-constant 3087 | array-constructor 3088 | function-reference 3089 | '(' expr ')' 3090 { sprintf($$,"(%s)",$2);} 3091 ; 3092 3093 /* R702 : level-1-expr */ 3094 level-1-expr: primary 3095 {strcpy(my_dim.last,"");} 3096 ; 3097 3098 /* R704 : mult-operand */ 3099 mult-operand: level-1-expr 3100 | level-1-expr power-op mult-operand 3101 {sprintf($$,"%s**%s",$1,$3);} 3102 ; 3103 /* R705 : add-operand */ 3104 add-operand: mult-operand 3105 | add-operand mult-op mult-operand 3106 { sprintf($$,"%s%s%s",$1,$2,$3); } 3107 ; 3108 3109 /* R706 : level-2-expr */ 3110 /* add signed-int-literal-constant because potential reduce conflict with add-op add-operand */ 3111 3112 level-2-expr: add-operand 3113 | add-op add-operand 3114 { sprintf($$,"%s%s",$1,$2); } 3115 | level-2-expr add-op add-operand 3116 { sprintf($$,"%s%s%s",$1,$2,$3); } 3117 | signed-int-literal-constant 3118 | level-2-expr signed-int-literal-constant 3119 { sprintf($$,"%s%s",$1,$2); } 3120 ; 3121 3122 /* R707 : power-op */ 3123 power-op : TOK_DASTER 3124 ; 3125 3126 /* R708 : mult-op */ 3127 mult-op : '*' 3128 {strcpy($$,"*");} 3129 | TOK_SLASH 3130 ; 3131 3132 /* R709 : add-op */ 3133 add-op : '+' 3134 {strcpy($$,"+");} 3135 | '-' 3136 {strcpy($$,"-");} 3137 ; 3138 3139 /* R710 : level-3-expr */ 3140 level-3-expr: level-2-expr 3141 | level-3-expr concat-op level-2-expr 3142 { sprintf($$,"%s%s%s",$1,$2,$3); } 3143 ; 3144 3145 /* R711 : concat-op */ 3146 concat-op : TOK_DSLASH 3147 ; 3148 /* R712 : level-4-expr */ 3149 level-4-expr: level-3-expr 3150 | level-3-expr rel-op level-3-expr 3151 { sprintf($$,"%s%s%s",$1,$2,$3); } 3152 ; 3153 3154 /* R713 : rel-op */ 3155 rel-op : TOK_EQ 3156 | TOK_NE 3157 | TOK_LT 3158 | TOK_LE 3159 | TOK_GT 3160 | TOK_GE 3161 | TOK_EQUALEQUAL 3162 | TOK_SLASHEQUAL 3163 | '<' 3164 {strcpy($$,"<");} 3165 | TOK_INFEQUAL 3166 | '>' 3167 {strcpy($$,">");} 3168 | TOK_SUPEQUAL 3169 ; 3170 3171 /* R714 : and-operand */ 3172 /* level-4-expr inlined as level-3-expr */ 3173 and-operand: level-4-expr 3174 | not-op level-4-expr 3175 { sprintf($$,"%s%s",$1,$2); } 3176 ; 3177 3178 3179 /* R715 : or-operand */ 3180 or-operand: and-operand 3181 | or-operand and-op and-operand 3182 { sprintf($$,"%s%s%s",$1,$2,$3); } 3183 ; 3184 3185 3186 /* R716 : equiv-operand */ 3187 equiv-operand : or-operand 3188 | equiv-operand or-op or-operand 3189 { sprintf($$,"%s%s%s",$1,$2,$3); } 3190 ; 3191 3192 /* R717 : level-5-expr */ 3193 level-5-expr: equiv-operand 3194 | level-5-expr equiv-op equiv-operand 3195 { sprintf($$,"%s%s%s",$1,$2,$3); } 3196 ; 3197 3198 /* R718 : not-op */ 3199 not-op: TOK_NOT 3200 ; 3201 3202 /* R719 : and-op */ 3203 and-op: TOK_AND 3204 ; 3205 3206 /* R720 : or-op */ 3207 or-op: TOK_OR 3208 ; 3209 3210 /* R721 : equiv-op */ 3211 equiv-op: TOK_EQV 3212 | TOK_NEQV 3213 ; 3214 3215 /* R722 : expr */ 3216 expr: level-5-expr 3217 ; 3218 3219 scalar-default-char-expr: default-char-expr 3220 ; 3221 3222 /* R725 : default-char-expr */ 3223 default-char-expr : expr 3224 ; 3225 3226 /* R726 : int-expr */ 3227 int-expr: expr 3228 ; 3229 3230 opt-scalar-int-expr: 3231 {strcpy($$,"");} 3232 | scalar-int-expr 3233 ; 3234 3235 scalar-int-expr: int-expr 3236 ; 3237 3238 /* R728 : specification-expr */ 3239 specification-expr: scalar-int-expr 3240 { 3241 strcpy($$,$1); 3242 } 3243 ; 3244 3245 /* R729 : constant-expr */ 3246 constant-expr: expr 3247 {strcpy($$,$1);} 3248 ; 3249 3250 scalar-default-char-constant-expr: default-char-constant-expr 3251 ; 3252 3253 /* R730: default-char-constant-expr */ 3254 default-char-constant-expr: default-char-expr 3255 ; 3256 3257 scalar-int-constant-expr: int-constant-expr 3258 ; 3259 3260 /* R731 : int-constant-expr */ 3261 int-constant-expr: int-expr 3262 ; 3263 3264 /* R732 : assignment-stmt */ 3265 /* cannot use opt-label due to conflicts ... */ 3266 3267 assignment-stmt: variable '=' expr line-break 3268 | label variable '=' expr line-break 3269 ; 3270 3271 /* R733 : pointer-assignment-stmt */ 3272 3273 /* data-pointer-object and proc-pointer-object replaced by designator */ 3274 /*pointer-assignment-stmt: data-pointer-object opt-bounds-spec-list-par TOK_POINT_TO data-target line-break 3275 | data-pointer-object '(' bounds-remapping-list ')' TOK_POINT_TO data-target line-break 3276 | proc-pointer-object TOK_POINT_TO proc-target line-break 3277 ; 3278 */ 3279 3280 pointer-assignment-stmt: designator opt-bounds-spec-list-par TOK_POINT_TO data-target line-break 3281 | designator '(' bounds-remapping-list ')' TOK_POINT_TO data-target line-break 3282 | designator TOK_POINT_TO proc-target line-break 3283 ; 3284 3285 /* R734 : data-pointer-object */ 3286 data-pointer-object: variable-name 3287 | scalar-variable '%' TOK_NAME 3288 ; 3289 3290 opt-bounds-spec-list-par: 3291 | '(' bounds-spec-list ')' 3292 ; 3293 3294 bounds-spec-list: 3295 bounds-spec 3296 | bounds-spec-list ',' bounds-spec 3297 ; 3298 3299 bounds-remapping-list: 3300 bounds-remapping 3301 | bounds-remapping-list ',' bounds-remapping 3302 ; 3303 3304 /* R735 : bounds-spec */ 3305 bounds-spec: lower-bound-expr ':' 3306 ; 3307 3308 /* R736 : bounds-remapping */ 3309 bounds-remapping: lower-bound-expr ':' upper-bound-expr 3310 ; 3311 3312 /* R737 : data-target */ 3313 data-target: variable 3314 ; 3315 3316 procedure-component-name: TOK_NAME 3317 ; 3318 3319 /* R738 : proc-pointer-object */ 3320 proc-pointer-object: proc-pointer-name 3321 | proc-component-ref 3322 ; 3323 3324 /* R739 : proc-component-ref */ 3325 proc-component-ref : scalar-variable '%' procedure-component-name 3326 ; 3327 3328 /* R740 : proc-target */ 3329 proc-target: expr 3330 | procedure-component-name 3331 | proc-component-ref 3332 ; 3333 3334 /* R741 : where-stmt */ 3335 where-stmt: TOK_WHERE '(' mask-expr ')' where-assignment-stmt 3336 ; 3337 3338 /* R742 : where-construct */ 3339 where-construct: where-construct-stmt opt-where-body-construct opt-masked-elsewhere-construct opt-elsewhere-construct end-where-stmt 3340 ; 3341 3342 opt-where-body-construct: 3343 | opt-where-body-construct where-body-construct 3344 ; 3345 3346 opt-masked-elsewhere-construct : 3347 | opt-masked-elsewhere-construct masked-elsewhere-stmt opt-where-body-construct 3348 ; 3349 3350 opt-elsewhere-construct: 3351 | opt-elsewhere-construct elsewhere-stmt opt-where-body-construct 3352 ; 3353 3354 /* R743 : where-construct-stmt */ 3355 where-construct-stmt: TOK_WHERE '(' mask-expr ')' line-break 3356 ; 3357 3358 /* R744 : where-body-construct */ 3359 where-body-construct: where-assignment-stmt 3360 | where-stmt 3361 | where-construct 3362 ; 3363 3364 /* R745 : where-assignment-stmt */ 3365 where-assignment-stmt: assignment-stmt 3366 ; 3367 3368 /* R746 : mask-expr */ 3369 mask-expr: expr 3370 ; 3371 3372 /* R747 : masked-elsewhere-stmt */ 3373 masked-elsewhere-stmt: TOK_ELSEWHEREPAR mask-expr ')' line-break 3374 | TOK_ELSEWHEREPAR mask-expr ')' TOK_NAME line-break 3375 ; 3376 3377 /* R748: elsewhere-stmt */ 3378 elsewhere-stmt: TOK_ELSEWHERE line-break 3379 | TOK_ELSEWHERE TOK_NAME line-break 3380 ; 3381 3382 /* R749: end-where-stmt */ 3383 end-where-stmt: 3384 TOK_ENDWHERE line-break 3385 | TOK_ENDWHERE TOK_NAME line-break 3386 ; 3387 3388 /* R752 : forall-header */ 3389 forall-header : 3390 ; 3391 3392 /* R801 : block */ 3393 block: opt-execution-part-construct 3394 ; 3395 3396 opt-execution-part-construct: 3397 | opt-execution-part-construct execution-part-construct 3398 ; 3399 3400 /* R813 : do-construct */ 3401 do-construct: 3402 block-do-construct 3403 | nonblock-do-construct 3404 ; 3405 3406 do-construct: 3407 block-do-construct 3408 ; 3409 3410 /* R814 : block-do-construct */ 3411 3412 block-do-construct: label-do-stmt do-block end-do 3413 | nonlabel-do-stmt do-block end-do 3414 ; 3415 3416 /* R815 : do-stmt */ 3417 /*do-stmt: 3418 label-do-stmt 3419 | nonlabel-do-stmt 3420 ; 3421 */ 3422 3423 /* R816 : label-do-stmt */ 3424 label-do-stmt: TOK_NAME ':' TOK_PLAINDO_LABEL line-break 3425 | TOK_PLAINDO_LABEL line-break 3426 | TOK_NAME ':' TOK_PLAINDO_LABEL loop-control line-break 3427 | TOK_PLAINDO_LABEL loop-control line-break 3428 ; 3429 3430 label-do-stmt-djview: TOK_NAME ':' TOK_PLAINDO_LABEL_DJVIEW line-break 3431 | TOK_PLAINDO_LABEL_DJVIEW line-break 3432 | TOK_NAME ':' TOK_PLAINDO_LABEL_DJVIEW loop-control line-break 3433 | TOK_PLAINDO_LABEL_DJVIEW loop-control line-break 3434 ; 3435 3436 /* R817 : nonlabel-do-stmt */ 3437 nonlabel-do-stmt: TOK_NAME ':' TOK_PLAINDO line-break 3438 | TOK_PLAINDO line-break 3439 | TOK_NAME ':' TOK_PLAINDO loop-control line-break 3440 | TOK_PLAINDO loop-control line-break 3441 ; 3442 3443 /* R818 : loop-control */ 3444 loop-control: 3445 opt_comma do-variable '=' expr ',' expr 3446 | opt_comma do-variable '=' expr ',' expr ',' expr 3447 | opt_comma TOK_WHILE '(' expr ')' 3448 | opt_comma TOK_CONCURRENT forall-header 3449 ; 3450 3451 /* R819 : do-variable */ 3452 do-variable: ident 3453 ; 3454 3455 /* R820 : do-block */ 3456 do-block: block 3457 ; 3458 3459 /* R821 : end-do */ 3460 /*end-do: end-do-stmt 3461 | do-term-action-stmt 3462 ; 3463 */ 3464 3465 end-do: end-do-stmt 3466 | label-djview continue-stmt 3467 ; 3468 3469 /* R822 : end-do-stmt */ 3470 end-do-stmt: opt-label-djview TOK_ENDDO line-break 3471 | opt-label-djview TOK_ENDDO TOK_NAME line-break 3472 ; 3473 3474 /* R823 : nonblock-do-construct */ 3475 /* only outer-shared-do-construct is used */ 3476 3477 /* 3478 nonblock-do-construct: outer-shared-do-construct 3479 ; 3480 */ 3481 3482 nonblock-do-construct: action-term-do-construct 3483 | outer-shared-do-construct 3484 ; 3485 3486 3487 /* R824 : action-term-do-construct */ 3488 3489 action-term-do-construct: label-do-stmt do-block do-term-action-stmt 3490 ; 3491 3492 /* R825 : do-body */ 3493 3494 do-body : 3495 | execution-part-construct do-body 3496 ; 3497 3498 /* R826 : do-term-action-stmt */ 3499 do-term-action-stmt: label-djview do-term-action-stmt-special 3500 ; 3501 3502 /* do-term-action-stmt-special */ 3503 do-term-action-stmt-special: 3504 allocate-stmt 3505 | assignment-stmt 3506 | call-stmt 3507 | close-stmt 3508 | deallocate-stmt 3509 | flush-stmt 3510 | goto-stmt 3511 | TOK_REWIND after_rewind 3512 | TOK_NULLIFY '(' pointer_name_list ')' 3513 | if-stmt 3514 | inquire-stmt 3515 | open-stmt 3516 | print-stmt 3517 | read-stmt 3518 | rewind-stmt 3519 | where-stmt 3520 | write-stmt 3521 ; 3522 3523 3524 /* R827 : outer-shared-do-construct */ 3525 /* do-body is same as do-block 3526 we extend the definition of outer-shared-do-construct 3527 a label-do-stmt statement must be followed by a label-do-stmt-djview statement 3528 */ 3529 3530 outer-shared-do-construct : label-do-stmt do-block label-do-stmt-djview-do-block-list inner-shared-do-construct 3531 | label-do-stmt do-block inner-shared-do-construct 3532 ; 3533 3534 label-do-stmt-djview-do-block-list: label-do-stmt-djview do-block 3535 | label-do-stmt-djview-do-block-list label-do-stmt-djview do-block 3536 ; 3537 3538 /* R828 : shared-term-do-construct */ 3539 3540 shared-term-do-construct: outer-shared-do-construct 3541 | inner-shared-do-construct 3542 ; 3543 3544 /* R829 : inner-shared-do-construct */ 3545 /* do-body is same as do-block */ 3546 inner-shared-do-construct: label-do-stmt-djview do-block do-term-shared-stmt 3547 ; 3548 3549 /* R830 : do-term-shared-stmt */ 3550 3551 do-term-shared-stmt: label-djview action-stmt 3552 ; 3553 3554 opt-do-construct-name: 3555 | TOK_NAME 3556 ; 3557 3558 /* R831 : cycle-stmt */ 3559 cycle-stmt: TOK_CYCLE opt-do-construct-name line-break 3560 ; 3561 3562 /* R832 : if-construct */ 3563 if-construct: if-then-stmt block opt-else-if-stmt-block opt-else-stmt-block end-if-stmt 3564 ; 3565 3566 opt-else-if-stmt-block: 3567 | else-if-stmt-block 3568 | opt-else-if-stmt-block else-if-stmt-block 3569 ; 3570 3571 else-if-stmt-block: else-if-stmt block 3572 ; 3573 3574 opt-else-stmt-block: 3575 | else-stmt-block 3576 | opt-else-stmt-block else-if-stmt-block 3577 ; 3578 3579 else-stmt-block: else-stmt block 3580 ; 3581 3582 /* R833 : if-then-stmt */ 3583 if-then-stmt: TOK_NAME ':' TOK_LOGICALIF_PAR expr ')' TOK_THEN line-break 3584 | label TOK_NAME ':' TOK_LOGICALIF_PAR expr ')' TOK_THEN line-break 3585 | opt-label TOK_LOGICALIF_PAR expr ')' TOK_THEN line-break 3586 ; 3587 3588 /* R834 : else-if-stmt */ 3589 else-if-stmt:TOK_ELSEIF '(' expr ')' TOK_THEN line-break 3590 | TOK_ELSEIF '(' expr ')' TOK_THEN TOK_NAME line-break 3591 ; 3592 3593 /* R835 : else-stmt */ 3594 else-stmt:TOK_ELSE line-break 3595 | TOK_ELSE TOK_NAME line-break 3596 ; 3597 3598 /* R836 : end-if-stmt */ 3599 end-if-stmt:TOK_ENDIF line-break 3600 | TOK_ENDIF TOK_NAME line-break 3601 ; 3602 3603 /* R837 : if-stmt */ 3604 if-stmt: opt-label TOK_LOGICALIF_PAR expr ')' action-stmt 3605 ; 3606 3607 /* R838 : case-construct */ 3608 case-construct: select-case-stmt opt_case-stmt-block end-select-stmt 3609 ; 3610 3611 opt_case-stmt-block: 3612 | case-stmt-block 3613 | opt_case-stmt-block case-stmt-block 3614 ; 3615 3616 case-stmt-block: case-stmt block 3617 ; 3618 3619 /* R839 : select-case-stmt */ 3620 select-case-stmt :TOK_NAME ':' TOK_SELECTCASE '(' expr ')' {in_select_case_stmt++;} line-break 3621 | TOK_SELECTCASE '(' expr ')' {in_select_case_stmt++;} line-break 3622 ; 3623 3624 /* R840 : case-stmt */ 3625 case-stmt:TOK_CASE case-selector line-break 3626 | TOK_CASE case-selector TOK_NAME line-break 3627 ; 3628 3629 /* R840 : end-select-stmt */ 3630 end-select-stmt: TOK_ENDSELECT {in_select_case_stmt--;} line-break 3631 | TOK_ENDSELECT TOK_NAME {in_select_case_stmt--;} line-break 3632 ; 3633 3634 /* R843 : case-selector */ 3635 case-selector: 3636 '(' {in_complex_literal=0;} case-value-range-list ')' 3637 | TOK_DEFAULT 3638 ; 3639 3640 case-value-range-list: 3641 case-value-range 3642 | case-value-range-list ',' case-value-range 3643 ; 3644 3645 /* R844: case-value-range */ 3646 case-value-range : 3647 case-value 3648 | case-value ':' 3649 | ':' case-value 3650 | case-value ':' case-value 3651 ; 3652 3653 /* R845 : case-value */ 3654 case-value: expr 3655 ; 3656 3657 /* R850 : exit-stmt */ 3658 exit-stmt: TOK_EXIT line-break 3659 | TOK_EXIT TOK_NAME line-break 3660 ; 3661 3662 /* R851 : goto-stmt */ 3663 goto-stmt: TOK_PLAINGOTO label line-break 3664 ; 3665 3666 /* R853 arithmetic-if-stmt */ 3667 arithmetic-if-stmt: opt-label TOK_LOGICALIF_PAR expr ')' label ',' label ',' label line-break 3668 ; 3669 3670 /* R854 : continue-stmt */ 3671 continue-stmt: opt-label TOK_CONTINUE line-break 3672 ; 3673 3674 /* R855 : stop-stmt */ 3675 stop-stmt: TOK_STOP line-break 3676 | TOK_STOP stop-code line-break 3677 ; 3678 3679 /* R857 : stop-code */ 3680 stop-code: scalar-default-char-constant-expr 3681 | scalar-int-constant-expr 3682 ; 3683 3684 /* R901 : io-unit */ 3685 io-unit : file-unit-number 3686 | '*' 3687 | internal-file-variable 3688 ; 3689 3690 /* R902 : file-unit-number */ 3691 file-unit-number : scalar-int-expr 3692 ; 3693 3694 /* R902 : internal-file-variable */ 3695 internal-file-variable : char-variable 3696 ; 3697 3698 /* R904 : open-stmt */ 3699 open-stmt: TOK_OPEN '(' {close_or_connect = 1;} connect-spec-list ')' {close_or_connect = 0;} line-break 3700 ; 3701 3702 connect-spec-list: connect-spec 3703 | connect-spec-list ',' connect-spec 3704 ; 3705 3706 /* R905 : connect-spec */ 3707 connect-spec: file-unit-number 3708 | TOK_UNIT file-unit-number 3709 | TOK_ACCESS scalar-default-char-expr 3710 | TOK_ACTION scalar-default-char-expr 3711 | TOK_ERR label 3712 | TOK_FILE file-name-expr 3713 | TOK_FORM scalar-default-char-expr 3714 | TOK_IOSTAT scalar-int-variable 3715 | TOK_POSITION scalar-default-char-expr 3716 | TOK_RECL scalar-int-expr 3717 | TOK_STATUS '=' scalar-default-char-expr 3718 ; 3719 3720 /* R906 : file-name-expr */ 3721 file-name-expr: scalar-default-char-expr 3722 ; 3723 3724 /* R907 : iomsg-variable */ 3725 iomsg-variable: scalar-default-char-variable 3726 ; 3727 3728 /* R908 : close-stmt */ 3729 close-stmt: opt-label TOK_CLOSE '(' {close_or_connect = 1;} close-spec-list ')' line-break 3730 {close_or_connect = 0;} 3731 ; 3732 3733 close-spec-list: close-spec 3734 | close-spec-list ',' close-spec 3735 ; 3736 3737 /* R909 : close-spec */ 3738 close-spec: file-unit-number 3739 | TOK_UNIT file-unit-number 3740 | TOK_IOSTAT scalar-int-variable 3741 | TOK_ERR label 3742 | TOK_STATUS '=' scalar-default-char-expr 3743 ; 3744 3745 /* R910 : read-stmt */ 3746 read-stmt: opt-label TOK_READ_PAR io-control-spec-list ')' 3747 { 3748 in_io_control_spec = 0; 3749 } 3750 line-break 3751 | opt-label TOK_READ_PAR io-control-spec-list ')' input-item-list 3752 { 3753 in_io_control_spec = 0; 3754 } 3755 line-break 3756 | opt-label TOK_READ format line-break 3757 | opt-label TOK_READ format ',' input-item-list line-break 3758 ; 3759 3760 /* R911 : write-stmt */ 3761 write-stmt: opt-label TOK_WRITE_PAR io-control-spec-list ')' 3762 { 3763 in_io_control_spec = 0; 3764 } 3765 line-break 3766 | opt-label TOK_WRITE_PAR io-control-spec-list ')' output-item-list 3767 { 3768 in_io_control_spec = 0; 3769 } 3770 line-break 3771 ; 3772 3773 /* R912 : print-stmt */ 3774 print-stmt: opt-label TOK_PRINT format line-break 3775 | opt-label TOK_PRINT format ',' output-item-list line-break 3776 ; 3777 io-control-spec-list: io-control-spec 3778 | io-control-spec-list ',' io-control-spec 3779 ; 3780 3781 namelist-group-name: TOK_NAME 3782 ; 3783 3784 /* R913 : io-control-spec */ 3785 io-control-spec: io-unit 3786 | TOK_UNIT io-unit 3787 | format 3788 | namelist-group-name 3789 | TOK_NML namelist-group-name 3790 | TOK_FMT format 3791 | TOK_END label 3792 | TOK_EOR label 3793 | TOK_ERR label 3794 | TOK_IOSTAT scalar-int-variable 3795 | TOK_REC '=' scalar-int-expr 3796 ; 3797 3798 /* R915 : format */ 3799 format: default-char-expr 3800 | label 3801 | '*' 3802 ; 3803 input-item-list: 3804 input-item 3805 | input-item-list ',' input-item 3806 ; 3807 /* R916 : input-item */ 3808 input-item: variable 3809 | io-implied-do 3810 ; 3811 3812 output-item-list: 3813 output-item 3814 | output-item-list ',' output-item 3815 ; 3816 3817 /* R917 : output-item */ 3818 output-item: expr 3819 | io-implied-do 3820 ; 3821 3822 /* R918 : io-implied-do */ 3823 io-implied-do : '(' io-implied-do-object-list ',' io-implied-do-control ')' 3824 ; 3825 3826 io-implied-do-object-list: io-implied-do-object 3827 | io-implied-do-object-list ',' io-implied-do-object 3828 ; 3829 3830 /* R919 : io-implied-do-object */ 3831 /* input-item removed since possible conflicts (output-item can be variable) */ 3832 /* io-implied-do-object : input-item 3833 | output-item 3834 ; 3835 */ 3836 3837 io-implied-do-object : output-item 3838 ; 3839 3840 /* R920 : io-implied-do-control */ 3841 io-implied-do-control: do-variable '=' scalar-int-expr ',' scalar-int-expr 3842 | do-variable '=' scalar-int-expr ',' scalar-int-expr ',' scalar-int-expr 3843 ; 3844 3845 /* R926 : rewind-stmt */ 3846 rewind-stmt: TOK_REWIND file-unit-number line-break 3847 | TOK_REWIND '(' position-spec-list ')' line-break 3848 ; 3849 3850 position-spec-list: 3851 position-spec 3852 | position-spec-list ',' position-spec 3853 ; 3854 3855 /* R927 : position-spec */ 3856 position-spec: file-unit-number 3857 | TOK_UNIT file-unit-number 3858 | TOK_IOMSG iomsg-variable 3859 | TOK_IOSTAT scalar-int-variable 3860 | TOK_ERR label 3861 ; 3862 3863 /* R928 : flush-stmt */ 3864 flush-stmt: TOK_FLUSH file-unit-number line-break 3865 | TOK_FLUSH '(' flush-spec-list ')' line-break 3866 ; 3867 3868 flush-spec-list: 3869 flush-spec 3870 | flush-spec-list ',' flush-spec 3871 ; 3872 3873 /* R929 : flush-spec */ 3874 flush-spec: file-unit-number 3875 | TOK_UNIT file-unit-number 3876 | TOK_IOSTAT scalar-int-variable 3877 | TOK_IOMSG iomsg-variable 3878 | TOK_ERR label 3879 ; 3880 3881 3882 /* R930 : inquire-stmt */ 3883 inquire-stmt: TOK_INQUIRE set_in_inquire '(' inquire-spec-list ')' 3884 {in_inquire=0;} 3885 line-break 3886 | TOK_INQUIRE set_in_inquire '(' TOK_IOLENGTH scalar-int-variable ')' output-item-list 3887 {in_inquire=0;} 3888 line-break 3889 ; 3890 3891 set_in_inquire: {in_inquire=1;} 3892 ; 3893 3894 inquire-spec-list: 3895 inquire-spec 3896 | inquire-spec-list ',' inquire-spec 3897 ; 3898 3899 /* R931 : inquire-spec */ 3900 inquire-spec: file-unit-number 3901 | TOK_UNIT file-unit-number 3902 | TOK_FILE file-name-expr 3903 | TOK_ACCESS scalar-default-char-variable 3904 | TOK_ACTION scalar-default-char-variable 3905 | TOK_ERR label 3906 | TOK_EXIST scalar-logical-variable 3907 | TOK_IOSTAT scalar-int-variable 3908 | TOK_NAME_EQ '=' scalar-default-char-variable 3909 | TOK_OPENED scalar-logical-variable 3910 | TOK_RECL scalar-int-variable 3911 ; 3912 3913 /* R1001 : format-stmt */ 3914 format-stmt: TOK_LABEL_FORMAT line-break 3915 ; 3916 3917 /* R1104 : module */ 3918 module:module-stmt opt-specification-part opt-module-subprogram-part {pos_endsubroutine=setposcur();} end-module-stmt 3919 ; 3920 3921 opt-module-subprogram-part: 3922 | module-subprogram-part 3923 ; 3924 3925 /* R1105 : module-stmt */ 3926 module-stmt : TOK_MODULE TOK_NAME 3927 { 3928 GlobalDeclaration = 0; 3929 strcpy(curmodulename,$2); 3930 strcpy(subroutinename,""); 3931 Add_NameOfModule_1($2); 3932 if ( inmoduledeclare == 0 ) 3933 { 3934 /* To know if there are in the module declaration */ 3935 inmoduledeclare = 1; 3936 /* to know if a module has been met */ 3937 inmodulemeet = 1; 3938 /* to know if we are after the keyword contains */ 3939 aftercontainsdeclare = 0 ; 3940 } 3941 } 3942 line-break 3943 ; 3944 3945 /* R1106 : end-module-stmt */ 3946 end-module-stmt: get_my_position TOK_ENDUNIT opt-tok-module opt-ident 3947 { 3948 /* if we never meet the contains keyword */ 3949 if ( firstpass == 0 ) 3950 { 3951 RemoveWordCUR_0(fortran_out, setposcur()-my_position); // Remove word "end module" 3952 if ( inmoduledeclare && ! aftercontainsdeclare ) 3953 { 3954 Write_Closing_Module(1); 3955 } 3956 fprintf(fortran_out,"\n end module %s\n", curmodulename); 3957 if ( module_declar && insubroutinedeclare == 0 ) 3958 { 3959 fclose(module_declar); 3960 } 3961 } 3962 inmoduledeclare = 0 ; 3963 inmodulemeet = 0 ; 3964 aftercontainsdeclare = 1; 3965 strcpy(curmodulename, ""); 3966 GlobalDeclaration = 0 ; 3967 } 3968 line-break 3969 ; 3970 3971 opt-tok-module: 3972 | TOK_MODULE 3973 ; 3974 3975 opt-ident: 3976 | TOK_NAME 3977 ; 3978 /* R1107 : module-subprogram-part */ 3979 module-subprogram-part:contains-stmt opt-module-subprogram-list 3980 ; 3981 3982 opt-module-subprogram-list: 3983 | module-subprogram-list 3984 ; 3985 3986 module-subprogram-list: module-subprogram 3987 | module-subprogram-list module-subprogram 3988 ; 3989 3990 module-subprogram: function-subprogram 3991 | subroutine-subprogram 3992 ; 3993 3994 use-stmt-list:use-stmt 3995 | use-stmt-list use-stmt 3996 ; 3997 3998 save_olduse: 3999 {if (firstpass == 0 && oldfortran_out) pos_curuseold = setposcurname(oldfortran_out);} 4000 ; 4001 4002 /* R1109 use-stmt */ 4003 use-stmt: get_my_position TOK_USE save_olduse opt-module-nature-2points TOK_NAME opt-rename-list 4004 { 1355 4005 if ( firstpass ) 1356 4006 { 1357 4007 if ( insubroutinedeclare ) 1358 4008 { 1359 Add_CouplePointed_Var_1($2,$4); 1360 coupletmp = $4; 1361 strcpy(ligne,""); 1362 while ( coupletmp ) 1363 { 4009 if ($6) { 4010 Add_CouplePointed_Var_1($5,$6); 4011 coupletmp = $6; 4012 strcpy(ligne,""); 4013 while ( coupletmp ) 4014 { 1364 4015 strcat(ligne, coupletmp->c_namevar); 1365 4016 strcat(ligne, " => "); … … 1367 4018 coupletmp = coupletmp->suiv; 1368 4019 if ( coupletmp ) strcat(ligne,","); 4020 } 4021 } 4022 sprintf(charusemodule,"%s",$5); 4023 } 4024 Add_NameOfModuleUsed_1($5); 4025 } 4026 else 4027 { 4028 if ( insubroutinedeclare ) 4029 { 4030 copyuse_0($5); 1369 4031 } 1370 sprintf(charusemodule,"%s",$2);1371 }1372 Add_NameOfModuleUsed_1($2);1373 }1374 if ( inmoduledeclare == 0 )1375 {1376 pos_end = setposcur();1377 RemoveWordSET_0(fortran_out,pos_curuse,pos_end-pos_curuse);1378 }1379 }1380 | word_use TOK_NAME ',' TOK_ONLY ':' '\n'1381 {1382 /* if variables has been declared in a subroutine */1383 sprintf(charusemodule,"%s",$2);1384 if ( firstpass )1385 {1386 Add_NameOfModuleUsed_1($2);1387 }1388 else1389 {1390 if ( insubroutinedeclare )1391 copyuseonly_0($2);1392 4032 1393 4033 if ( inmoduledeclare == 0 ) 1394 4034 { 1395 4035 pos_end = setposcur(); 1396 RemoveWordSET_0(fortran_out, pos_curuse,pos_end-pos_curuse);4036 RemoveWordSET_0(fortran_out,my_position,pos_end-my_position); 1397 4037 } 1398 4038 } 1399 1400 | word_use TOK_NAME ',' TOK_ONLY ':' only_list1401 {1402 /* if variables has been declared in a subroutine */4039 } 4040 line-break 4041 | get_my_position TOK_USE save_olduse opt-module-nature-2points TOK_NAME ',' TOK_ONLY ':' opt-only-list 4042 { 1403 4043 if ( firstpass ) 1404 4044 { 1405 4045 if ( insubroutinedeclare ) 1406 4046 { 1407 Add_CouplePointed_Var_1($2,$6); 1408 coupletmp = $6; 4047 if ($9) 4048 { 4049 Add_CouplePointed_Var_1($5,$9); 4050 coupletmp = $9; 1409 4051 strcpy(ligne,""); 1410 4052 while ( coupletmp ) … … 1416 4058 if ( coupletmp ) strcat(ligne,","); 1417 4059 } 1418 sprintf(charusemodule,"%s",$2); 4060 } 4061 sprintf(charusemodule,"%s",$5); 1419 4062 } 1420 Add_NameOfModuleUsed_1($2); 1421 } 1422 else /* if ( firstpass == 0 ) */ 1423 { 4063 Add_NameOfModuleUsed_1($5); 4064 } 4065 else 4066 { 4067 if ( insubroutinedeclare ) 4068 copyuseonly_0($5); 4069 1424 4070 if ( inmoduledeclare == 0 ) 1425 4071 { 1426 4072 pos_end = setposcur(); 1427 RemoveWordSET_0(fortran_out,pos_curuse,pos_end-pos_curuse); 1428 if (oldfortran_out) variableisglobalinmodule($6,$2,oldfortran_out,pos_curuseold); 4073 RemoveWordSET_0(fortran_out,my_position,pos_end-my_position); 4074 if ($9) 4075 { 4076 if (oldfortran_out) variableisglobalinmodule($9,$5,oldfortran_out,pos_curuseold); 4077 } 1429 4078 } 1430 4079 else 1431 4080 { 4081 if ($9) 4082 { 1432 4083 /* if we are in the module declare and if the */ 1433 4084 /* onlylist is a list of global variable */ 1434 variableisglobalinmodule($6, $2, fortran_out,pos_curuse); 4085 variableisglobalinmodule($9, $5, fortran_out,my_position); 4086 } 1435 4087 } 1436 4088 } 1437 } 1438 ; 1439 word_use : 1440 TOK_USE 1441 { 1442 pos_curuse = setposcur()-strlen($1); 1443 if (firstpass == 0 && oldfortran_out) pos_curuseold = setposcurname(oldfortran_out); 1444 } 1445 ; 1446 rename_list : 1447 rename_name 1448 { 1449 $$ = $1; 1450 } 1451 | rename_list ',' rename_name 1452 { 1453 /* insert the variable in the list $1 */ 1454 $3->suiv = $1; 1455 $$ = $3; 1456 } 1457 ; 1458 rename_name : TOK_NAME TOK_POINT_TO TOK_NAME 4089 } 4090 line-break 4091 ; 4092 4093 opt-module-nature-2points: 4094 | TOK_FOURDOTS 4095 | ',' module-nature TOK_FOURDOTS 4096 ; 4097 4098 opt-only-list: 4099 {$$=NULL;} 4100 | only-list 4101 {$$=$1;} 4102 ; 4103 4104 /* R1101 : main-program */ 4105 main-program: program-stmt opt-specification-part opt-execution-part opt-internal-subprogram-part end-program-stmt 4106 ; 4107 4108 opt-specification-part: 4109 | specification-part 4110 ; 4111 4112 opt-execution-part: 4113 | execution-part 4114 ; 4115 4116 /* R1102 : program-stmt */ 4117 program-stmt: TOK_PROGRAM TOK_NAME 4118 { 4119 strcpy(subroutinename,$2); 4120 insubroutinedeclare = 1; 4121 inprogramdeclare = 1; 4122 /* in the second step we should write the head of */ 4123 /* the subroutine sub_loop_<subroutinename> */ 4124 if ( ! firstpass ) 4125 WriteBeginof_SubLoop(); 4126 } 4127 line-break 4128 ; 4129 4130 /* R1103 : end-program-stmt */ 4131 end-program-stmt: {pos_endsubroutine=my_position_before;} TOK_ENDUNIT opt-tok-program opt-tok-name 4132 { 4133 insubroutinedeclare = 0; 4134 inprogramdeclare = 0; 4135 pos_cur = setposcur(); 4136 closeandcallsubloopandincludeit_0(3); 4137 functiondeclarationisdone = 0; 4138 strcpy(subroutinename,""); 4139 } 4140 line-break 4141 ; 4142 4143 opt-tok-program: 4144 | TOK_PROGRAM 4145 ; 4146 opt-tok-name: 4147 | TOK_NAME 4148 ; 4149 /* R1110 : module-nature */ 4150 module-nature: TOK_INTRINSIC 4151 ; 4152 4153 opt-rename-list: 4154 { 4155 $$=NULL; 4156 } 4157 | ',' rename-list 4158 { 4159 $$=$2; 4160 } 4161 ; 4162 4163 rename-list: rename 4164 { 4165 $$=$1; 4166 } 4167 | rename-list ',' rename 4168 { 4169 /* insert the variable in the list $1 */ 4170 $3->suiv = $1; 4171 $$=$3; 4172 } 4173 ; 4174 4175 /* R1111: rename */ 4176 rename: TOK_NAME TOK_POINT_TO TOK_NAME 1459 4177 { 1460 4178 coupletmp = (listcouple *) calloc(1,sizeof(listcouple)); … … 1464 4182 $$ = coupletmp; 1465 4183 } 1466 ; 1467 only_list : 1468 only_name { $$ = $1; } 1469 | only_list ',' only_name 4184 ; 4185 4186 only-list:only 4187 {$$=$1;} 4188 | only-list ',' only 1470 4189 { 1471 4190 /* insert the variable in the list $1 */ … … 1473 4192 $$ = $3; 1474 4193 } 1475 ; 1476 only_name : 1477 TOK_NAME TOK_POINT_TO TOK_NAME 1478 { 1479 coupletmp = (listcouple *)calloc(1,sizeof(listcouple)); 1480 strcpy(coupletmp->c_namevar,$1); 1481 strcpy(coupletmp->c_namepointedvar,$3); 1482 coupletmp->suiv = NULL; 1483 $$ = coupletmp; 1484 pointedvar = 1; 1485 Add_UsedInSubroutine_Var_1($1); 1486 } 1487 | TOK_NAME 4194 ; 4195 4196 /* R1112: only */ 4197 only:generic-spec 1488 4198 { 1489 4199 coupletmp = (listcouple *)calloc(1,sizeof(listcouple)); … … 1493 4203 $$ = coupletmp; 1494 4204 } 1495 ; 1496 1497 /* R209 : execution-part-construct */ 1498 execution-part-construct: 1499 executable-construct 1500 | format-stmt 1501 ; 1502 1503 /* R213 : executable-construct */ 1504 executable-construct: 1505 action-stmt 1506 | do-construct 1507 | case-construct 1508 | if-construct 1509 | where-construct 1510 ; 1511 1512 /* R214 : action-stmt */ 1513 action-stmt : 1514 TOK_CONTINUE 1515 | ident_dims after_ident_dims 1516 | goto 1517 | call 1518 | iofctl ioctl 1519 | read option_read 1520 | TOK_WRITE ioctl 1521 | TOK_WRITE ioctl outlist 1522 | TOK_REWIND after_rewind 1523 | TOK_ALLOCATE '(' allocation_list opt_stat_spec ')' { inallocate = 0; } 1524 | TOK_DEALLOCATE '(' allocate_object_list opt_stat_spec ')' { inallocate = 0; } 1525 | TOK_EXIT optexpr 1526 | TOK_RETURN opt_expr 1527 | TOK_CYCLE opt_expr 1528 | stop opt_expr 1529 | int_list 1530 | TOK_NULLIFY '(' pointer_name_list ')' 1531 | word_endunit 1532 { 4205 | only-use-name 4206 { 4207 coupletmp = (listcouple *)calloc(1,sizeof(listcouple)); 4208 strcpy(coupletmp->c_namevar,$1); 4209 strcpy(coupletmp->c_namepointedvar,""); 4210 coupletmp->suiv = NULL; 4211 $$ = coupletmp; 4212 } 4213 | rename 4214 { 4215 $$=$1; 4216 pointedvar = 1; 4217 Add_UsedInSubroutine_Var_1($1->c_namevar); 4218 } 4219 ; 4220 /* R1113 : only-use-name */ 4221 only-use-name: TOK_NAME 4222 ; 4223 4224 /* R1207: generic-spec */ 4225 generic-spec: TOK_NAME 4226 ; 4227 4228 /* R1210 : external-stmt */ 4229 external-stmt: TOK_EXTERNAL external-name-list line-break 4230 | TOK_EXTERNAL TOK_FOURDOTS external-name-list line-break 4231 ; 4232 4233 external-name-list: external-name 4234 | external-name-list ',' external-name 4235 ; 4236 4237 external-name: TOK_NAME 4238 ; 4239 4240 /* R1218 : intrinsic-stmt */ 4241 intrinsic-stmt: TOK_INTRINSIC opt-TOK_FOURDOTS intrinsic-procedure-name-list line-break 4242 ; 4243 4244 intrinsic-procedure-name-list: 4245 intrinsic-procedure-name 4246 | intrinsic-procedure-name-list ',' intrinsic-procedure-name 4247 ; 4248 4249 intrinsic-procedure-name: TOK_NAME 4250 ; 4251 4252 /* R1219 : function-reference */ 4253 function-reference: procedure-designator '(' ')' 4254 | procedure-designator '(' {in_complex_literal=0;} actual-arg-spec-list ')' 4255 {sprintf($$,"%s(%s)",$[procedure-designator],$[actual-arg-spec-list]);} 4256 ; 4257 4258 /* R1220 : 4259 */ 4260 call-stmt: before-call-stmt 4261 { 4262 inagrifcallargument = 0 ; 4263 incalldeclare=0; 4264 if ( oldfortran_out && (callagrifinitgrids == 1) && (firstpass == 0) ) 4265 { 4266 pos_end = setposcur(); 4267 RemoveWordSET_0(fortran_out,pos_curcall,pos_end-pos_curcall); 4268 strcpy(subofagrifinitgrids,subroutinename); 4269 } 4270 Instanciation_0(sameagrifname); 4271 } 4272 line-break 4273 | before-call-stmt '(' ')' 4274 { 4275 inagrifcallargument = 0 ; 4276 incalldeclare=0; 4277 if ( oldfortran_out && (callagrifinitgrids == 1) && (firstpass == 0) ) 4278 { 4279 pos_end = setposcur(); 4280 RemoveWordSET_0(fortran_out,pos_curcall,pos_end-pos_curcall); 4281 strcpy(subofagrifinitgrids,subroutinename); 4282 } 4283 Instanciation_0(sameagrifname); 4284 } 4285 line-break 4286 | before-call-stmt '(' {in_complex_literal=0;} actual-arg-spec-list ')' 4287 { 4288 inagrifcallargument = 0 ; 4289 incalldeclare=0; 4290 if ( oldfortran_out && (callagrifinitgrids == 1) && (firstpass == 0) ) 4291 { 4292 pos_end = setposcur(); 4293 RemoveWordSET_0(fortran_out,pos_curcall,pos_end-pos_curcall); 4294 strcpy(subofagrifinitgrids,subroutinename); 4295 } 4296 Instanciation_0(sameagrifname); 4297 } 4298 line-break 4299 ; 4300 4301 before-call-stmt: opt-label TOK_CALL {pos_curcall=my_position_before-strlen($[opt-label])-4;} procedure-designator 4302 { 4303 if (!strcasecmp($[procedure-designator],"MPI_Init") ) callmpiinit = 1; 4304 else callmpiinit = 0; 4305 4306 if (!strcasecmp($[procedure-designator],"Agrif_Init_Grids") ) 4307 { 4308 callagrifinitgrids = 1; 4309 strcpy(meetagrifinitgrids,subroutinename); 4310 } 4311 else 4312 { 4313 callagrifinitgrids = 0; 4314 } 4315 if ( Vartonumber($[procedure-designator]) == 1 ) 4316 { 4317 incalldeclare = 0; 4318 inagrifcallargument = 0 ; 4319 Add_SubroutineWhereAgrifUsed_1(subroutinename, curmodulename); 4320 } 4321 } 4322 ; 4323 4324 /* R1221 : procedure-designator */ 4325 procedure-designator: ident 4326 | TOK_FLUSH 4327 | TOK_REAL 4328 ; 4329 4330 actual-arg-spec-list: 4331 actual-arg-spec 4332 | actual-arg-spec-list ',' actual-arg-spec 4333 {sprintf($$,"%s,%s",$1,$[actual-arg-spec]);} 4334 ; 4335 4336 /* R1222 : actual-arg-spec */ 4337 actual-arg-spec: actual-arg 4338 { 4339 if ( callmpiinit == 1 ) 4340 { 4341 strcpy(mpiinitvar,$1); 4342 if ( firstpass == 1 ) Add_UsedInSubroutine_Var_1 (mpiinitvar); 4343 } 4344 } 4345 | keyword '=' actual-arg 4346 {sprintf($$,"%s = %s",$1,$3); 4347 if ( callmpiinit == 1 ) 4348 { 4349 strcpy(mpiinitvar,$3); 4350 if ( firstpass == 1 ) Add_UsedInSubroutine_Var_1 (mpiinitvar); 4351 } 4352 } 4353 ; 4354 4355 /* R1223 : actual-arg */ 4356 actual-arg: expr 4357 | variable 4358 { 4359 strcpy($$,$1->v_nomvar); 4360 if ($1->v_initialvalue_array) 4361 { 4362 strcat($$,"("); 4363 strcat($$,$1->v_initialvalue_array->n_name); 4364 strcat($$,")"); 4365 } 4366 } 4367 | ident 4368 ; 4369 4370 opt-prefix: {isrecursive = 0;} 4371 | prefix 4372 ; 4373 4374 /* R1225 : prefix */ 4375 prefix: prefix-spec 4376 | prefix prefix-spec 4377 ; 4378 4379 /* R1226 prefix-spec */ 4380 prefix-spec: declaration-type-spec 4381 {isrecursive = 0; functiondeclarationisdone = 1;} 4382 | TOK_MODULE 4383 {isrecursive = 0;} 4384 | TOK_RECURSIVE 4385 {isrecursive = 1;} 4386 ; 4387 4388 /*R1227 : function-subprogram */ 4389 function-subprogram: function-stmt opt-specification-part opt-execution-part opt-internal-subprogram-part end-function-stmt 4390 ; 4391 4392 /* R1228 : function-stmt */ 4393 function-stmt: opt-prefix TOK_FUNCTION 4394 function-name '(' {in_complex_literal=0;} opt-dummy-arg-list ')' opt-suffix 4395 { 4396 insubroutinedeclare = 1; 4397 suborfun = 0; 4398 /* we should to list of the subroutine argument the */ 4399 /* name of the function which has to be defined */ 4400 if ( firstpass ) 4401 { 4402 Add_SubroutineArgument_Var_1($[opt-dummy-arg-list]); 4403 if ( ! is_result_present ) 4404 Add_FunctionType_Var_1($[function-name]); 4405 } 4406 else 4407 /* in the second step we should write the head of */ 4408 /* the subroutine sub_loop_<subroutinename> */ 4409 { 4410 if (todebug == 1) fprintf(fortran_out," !DEBUG: Avant Writebeginof subloop\n"); 4411 WriteBeginof_SubLoop(); 4412 if (todebug == 1) fprintf(fortran_out," !DEBUG: Apres Writebeginof subloop\n"); 4413 } 4414 strcpy(NamePrecision,""); 4415 } 4416 line-break 4417 ; 4418 4419 function-name: TOK_NAME 4420 { 4421 if (strcmp(subroutinename,"")) 4422 { 4423 strcpy(old_subroutinename,subroutinename); // can occur in internal-subprogram 4424 old_oldfortran_out=oldfortran_out; 4425 } 4426 else 4427 { 4428 old_oldfortran_out=(FILE *)NULL; 4429 } 4430 strcpy($$,$1);strcpy(subroutinename,$1); 4431 } 4432 ; 4433 4434 opt-dummy-arg-name-list: 4435 | dummy-arg-name-list 4436 ; 4437 4438 dummy-arg-name-list: 4439 dummy-arg-name 4440 | dummy-arg-name-list ',' dummy-arg-name 4441 ; 4442 4443 /* R1230 : dummy-arg-name */ 4444 dummy-arg-name: TOK_NAME 4445 {strcpy($$,$1);} 4446 ; 4447 4448 opt-suffix: 4449 {is_result_present = 0; } 4450 | suffix 4451 ; 4452 4453 /* R1231 : suffix */ 4454 suffix: TOK_RESULT '(' TOK_NAME ')' 4455 {is_result_present = 1; 4456 if ( firstpass == 1 ) 4457 { 4458 strcpy(nameinttypenameback,nameinttypename); 4459 strcpy(nameinttypename,""); 4460 curvar = createvar($3,NULL); 4461 strcpy(nameinttypename,nameinttypenameback); 4462 strcpy(curvar->v_typevar,""); 4463 curlistvar = insertvar(NULL,curvar); 4464 Add_SubroutineArgument_Var_1(curlistvar); 4465 } 4466 } 4467 ; 4468 4469 /* R1232 : end-function-stmt */ 4470 end-function-stmt: get_my_position TOK_ENDUNIT opt-tok-function opt-ident close_subroutine 4471 {strcpy(DeclType, "");} 4472 line-break 4473 ; 4474 4475 opt-tok-function: 4476 | TOK_FUNCTION 4477 ; 4478 4479 /*R1233 : subroutine-subprogram */ 4480 subroutine-subprogram: subroutine-stmt opt-specification-part opt-execution-part opt-internal-subprogram-part end-subroutine-stmt 4481 ; 4482 4483 /* R1234 : subroutine-stmt */ 4484 subroutine-stmt: opt-prefix TOK_SUBROUTINE subroutine-name opt-dummy-arg-list-par 4485 { 4486 insubroutinedeclare = 1; 4487 suborfun = 1; 4488 if ( firstpass ) 4489 Add_SubroutineArgument_Var_1($4); 4490 else 4491 { 4492 WriteBeginof_SubLoop(); 4493 } 4494 } 4495 line-break 4496 ; 4497 4498 4499 subroutine-name: TOK_NAME 4500 { 4501 if (strcmp(subroutinename,"")) 4502 { 4503 strcpy(old_subroutinename,subroutinename); // can occur in internal-subprogram 4504 old_oldfortran_out=oldfortran_out; 4505 } 4506 else 4507 { 4508 old_oldfortran_out=(FILE *)NULL; 4509 } 4510 strcpy($$,$1);strcpy(subroutinename,$1); 4511 } 4512 ; 4513 4514 /* R1236 : end-subroutine-stmt */ 4515 4516 end-subroutine-stmt: get_my_position TOK_ENDUNIT opt-tok-subroutine opt-ident close_subroutine 4517 line-break 4518 ; 4519 4520 close_subroutine: 4521 {pos_endsubroutine = my_position; 1533 4522 GlobalDeclaration = 0 ; 1534 4523 if ( firstpass == 0 && strcasecmp(subroutinename,"") ) … … 1546 4535 insubroutinedeclare = 0 ; 1547 4536 pos_cur = setposcur(); 1548 closeandcallsubloopandincludeit_0( 1);4537 closeandcallsubloopandincludeit_0(suborfun); 1549 4538 functiondeclarationisdone = 0; 1550 4539 } … … 1565 4554 } 1566 4555 strcpy(subroutinename,""); 1567 } 1568 | word_endprogram opt_name 1569 { 1570 insubroutinedeclare = 0; 1571 inprogramdeclare = 0; 1572 pos_cur = setposcur(); 1573 closeandcallsubloopandincludeit_0(3); 1574 functiondeclarationisdone = 0; 1575 strcpy(subroutinename,""); 1576 } 1577 | word_endsubroutine opt_name 1578 { 1579 if ( strcasecmp(subroutinename,"") ) 1580 { 1581 insubroutinedeclare = 0; 1582 pos_cur = setposcur(); 1583 closeandcallsubloopandincludeit_0(1); 1584 functiondeclarationisdone = 0; 1585 strcpy(subroutinename,""); 1586 } 1587 } 1588 | word_endfunction opt_name 1589 { 1590 insubroutinedeclare = 0; 1591 pos_cur = setposcur(); 1592 closeandcallsubloopandincludeit_0(0); 1593 functiondeclarationisdone = 0; 1594 strcpy(subroutinename,""); 1595 } 1596 | TOK_ENDMODULE opt_name 1597 { 1598 /* if we never meet the contains keyword */ 1599 if ( firstpass == 0 ) 1600 { 1601 RemoveWordCUR_0(fortran_out, strlen($2)+11); // Remove word "end module" 1602 if ( inmoduledeclare && ! aftercontainsdeclare ) 1603 { 1604 Write_Closing_Module(1); 1605 } 1606 fprintf(fortran_out,"\n end module %s\n", curmodulename); 1607 if ( module_declar && insubroutinedeclare == 0 ) 1608 { 1609 fclose(module_declar); 1610 } 1611 } 1612 inmoduledeclare = 0 ; 1613 inmodulemeet = 0 ; 1614 aftercontainsdeclare = 1; 1615 strcpy(curmodulename, ""); 1616 GlobalDeclaration = 0 ; 1617 } 1618 | if-stmt 1619 | where-stmt 1620 | TOK_CONTAINS 4556 if (strcmp(old_subroutinename,"")) 4557 { 4558 strcpy(subroutinename,old_subroutinename); 4559 strcpy(old_subroutinename,""); 4560 oldfortran_out=old_oldfortran_out; 4561 insubroutinedeclare=1; 4562 } 4563 } 4564 ; 4565 opt-tok-subroutine: 4566 | TOK_SUBROUTINE 4567 ; 4568 4569 opt-dummy-arg-list-par: 4570 {if (firstpass) $$=NULL;} 4571 | '(' {in_complex_literal=0;} opt-dummy-arg-list ')' 4572 {if (firstpass) $$=$3;} 4573 ; 4574 4575 opt-dummy-arg-list: 4576 {if (firstpass) $$=NULL;} 4577 | dummy-arg-list 4578 {if (firstpass) $$=$1;} 4579 ; 4580 4581 dummy-arg-list: 4582 dummy-arg 4583 { 4584 if ( firstpass == 1 ) 4585 { 4586 strcpy(nameinttypenameback,nameinttypename); 4587 strcpy(nameinttypename,""); 4588 curvar = createvar($1,NULL); 4589 strcpy(nameinttypename,nameinttypenameback); 4590 curlistvar = insertvar(NULL,curvar); 4591 $$ = settype("",curlistvar); 4592 } 4593 } 4594 | dummy-arg-list ',' dummy-arg 4595 { 4596 if ( firstpass == 1 ) 4597 { 4598 strcpy(nameinttypenameback,nameinttypename); 4599 strcpy(nameinttypename,""); 4600 curvar = createvar($3,NULL); 4601 strcpy(nameinttypename,nameinttypenameback); 4602 $$ = insertvar($1,curvar); 4603 } 4604 } 4605 ; 4606 4607 /* R1235: dummy-arg */ 4608 dummy-arg: dummy-arg-name 4609 {strcpy($$,$1);} 4610 | '*' 4611 {strcpy($$,"*");} 4612 ; 4613 4614 /* R1241 : return-stmt */ 4615 return-stmt : opt-label TOK_RETURN line-break 4616 | opt-label TOK_RETURN scalar-int-expr line-break 4617 ; 4618 4619 /* R1242 : contains-stmt */ 4620 contains-stmt: opt-label TOK_CONTAINS 1621 4621 { 1622 4622 if ( inside_type_declare ) break; … … 1647 4647 else printf("l.%4d -- TOK_CONTAINS -- MHCHECK\n",line_num_input); 1648 4648 } 1649 ; 1650 1651 /* R601 : variable */ 1652 //variable : expr 1653 // ; 1654 1655 /* R734 : assignment-stmt */ 1656 // assignment-stmt: variable '=' expr 1657 // ; 1658 assignment-stmt: expr 1659 ; 1660 1661 /* R741 : where-stmt */ 1662 where-stmt: TOK_WHERE '(' mask-expr ')' where-assignment-stmt 1663 ; 1664 1665 /* R742 : where-construct */ 1666 where-construct: where-construct-stmt line-break opt-where-body-construct opt-masked-elsewhere-construct opt-elsewhere-construct end-where-stmt 1667 ; 1668 1669 opt-where-body-construct: 1670 | opt-where-body-construct where-body-construct line-break 1671 ; 1672 1673 opt-masked-elsewhere-construct : 1674 | opt-masked-elsewhere-construct masked-elsewhere-stmt line-break opt-where-body-construct 1675 ; 1676 1677 opt-elsewhere-construct: 1678 | opt-elsewhere-construct elsewhere-stmt line-break opt-where-body-construct 1679 ; 1680 1681 /* R743 : where-construct-stmt */ 1682 where-construct-stmt: 1683 TOK_WHERE '(' mask-expr ')' 1684 ; 1685 1686 /* R744 : where-body-construct */ 1687 where-body-construct: where-assignment-stmt 1688 | where-stmt 1689 | where-construct 1690 ; 1691 1692 /* R745 : where-assignment-stmt */ 1693 where-assignment-stmt: assignment-stmt 1694 ; 1695 1696 /* R746 : mask-expr */ 1697 mask-expr: expr 1698 ; 1699 1700 /* R747 : masked-elsewhere-stmt */ 1701 masked-elsewhere-stmt: 1702 TOK_ELSEWHEREPAR mask-expr ')' 1703 | TOK_ELSEWHEREPAR mask-expr ')' TOK_NAME 1704 ; 1705 1706 /* R748: elsewhere-stmt */ 1707 elsewhere-stmt: 1708 TOK_ELSEWHERE 1709 | TOK_ELSEWHERE TOK_NAME 1710 ; 1711 1712 /* R749: end-where-stmt */ 1713 end-where-stmt: 1714 TOK_ENDWHERE 1715 | TOK_ENDWHERE TOK_NAME 1716 ; 1717 1718 /* R752 : forall-header */ 1719 forall-header : 1720 ; 1721 1722 /* R801 : block */ 1723 block: 1724 |block execution-part-construct 1725 |block execution-part-construct line-break 1726 ; 1727 1728 /* R813 : do-construct */ 1729 do-construct: 1730 block-do-construct 1731 ; 1732 1733 /* R814 : block-do-construct */ 1734 block-do-construct: 1735 do-stmt line-break do-block end-do 1736 ; 1737 1738 /* R815 : do-stmt */ 1739 do-stmt: 1740 label-do-stmt 1741 | nonlabel-do-stmt 1742 ; 1743 1744 /* R816 : label-do-stmt */ 1745 label-do-stmt: 1746 TOK_NAME ':' TOK_PLAINDO label 1747 | TOK_PLAINDO label 1748 | TOK_NAME ':' TOK_PLAINDO label loop-control 1749 | TOK_PLAINDO label loop-control 1750 ; 1751 1752 /* R817 : nonlabel-do-stmt */ 1753 nonlabel-do-stmt: 1754 TOK_NAME ':' TOK_PLAINDO 1755 | TOK_PLAINDO 1756 | TOK_NAME ':' TOK_PLAINDO loop-control 1757 | TOK_PLAINDO loop-control 1758 ; 1759 1760 /* R818 : loop-control */ 1761 loop-control: 1762 opt_comma do-variable '=' expr ',' expr 1763 | opt_comma do-variable '=' expr ',' expr ',' expr 1764 | opt_comma TOK_WHILE '(' expr ')' 1765 | opt_comma TOK_CONCURRENT forall-header 1766 ; 1767 1768 /* R819 : do-variable */ 1769 do-variable : ident 1770 ; 1771 1772 /* R820 : do-block */ 1773 do-block: block 1774 ; 1775 1776 /* R821 : end-do */ 1777 end-do: end-do-stmt 1778 | continue-stmt 1779 ; 1780 1781 /* R822 : end-do-stmt */ 1782 end-do-stmt: 1783 TOK_ENDDO 1784 | TOK_ENDDO TOK_NAME 1785 ; 1786 1787 /* R832 : if-construct */ 1788 if-construct: if-then-stmt line-break block opt-else-if-stmt-block opt-else-stmt-block end-if-stmt 1789 ; 1790 1791 opt-else-if-stmt-block: 1792 | else-if-stmt-block 1793 | opt-else-if-stmt-block else-if-stmt-block 1794 ; 1795 1796 else-if-stmt-block: 1797 else-if-stmt line-break block 1798 ; 1799 1800 opt-else-stmt-block: 1801 | else-stmt-block 1802 | opt-else-stmt-block else-if-stmt-block 1803 ; 1804 1805 else-stmt-block: else-stmt line-break block 1806 ; 1807 1808 /* R833 : if-then-stmt */ 1809 if-then-stmt: 1810 TOK_NAME ':' TOK_LOGICALIF '(' expr ')' TOK_THEN 1811 | TOK_LOGICALIF '(' expr ')' TOK_THEN 1812 ; 1813 1814 /* R834 : else-if-stmt */ 1815 else-if-stmt: 1816 TOK_ELSEIF '(' expr ')' TOK_THEN 1817 | TOK_ELSEIF '(' expr ')' TOK_THEN TOK_NAME 1818 ; 1819 1820 /* R835 : else-stmt */ 1821 else-stmt: 1822 TOK_ELSE 1823 | TOK_ELSE TOK_NAME 1824 ; 1825 1826 /* R836 : end-if-stmt */ 1827 end-if-stmt: 1828 TOK_ENDIF 1829 | TOK_ENDIF TOK_NAME 1830 ; 1831 1832 /* R837 : if-stmt */ 1833 if-stmt: TOK_LOGICALIF '(' expr ')' action-stmt 1834 ; 1835 1836 /* R838 : case-construct */ 1837 case-construct: select-case-stmt line-break opt_case-stmt-block end-select-stmt 1838 ; 1839 1840 opt_case-stmt-block: 1841 | case-stmt-block 1842 | opt_case-stmt-block case-stmt-block 1843 ; 1844 1845 case-stmt-block: case-stmt line-break block 1846 ; 1847 1848 /* R839 : select-case-stmt */ 1849 select-case-stmt : 1850 TOK_NAME ':' TOK_SELECTCASE '(' expr ')' 1851 | TOK_SELECTCASE '(' expr ')' 1852 ; 1853 1854 /* R840 : case-stmt */ 1855 case-stmt: 1856 TOK_CASE case-selector 1857 | TOK_CASE case-selector TOK_NAME 1858 ; 1859 1860 /* R840 : end-select-stmt */ 1861 end-select-stmt: 1862 TOK_ENDSELECT 1863 | TOK_ENDSELECT TOK_NAME 1864 ; 1865 1866 /* R843 : case-selector */ 1867 case-selector: 1868 '(' case-value-range-list ')' 1869 | TOK_DEFAULT 1870 ; 1871 1872 case-value-range-list: 1873 case-value-range 1874 | case-value-range-list ',' case-value-range 1875 ; 1876 1877 /* R844: case-value-range */ 1878 case-value-range : 1879 case-value 1880 | case-value ':' 1881 | ':' case-value 1882 | case-value ':' case-value 1883 ; 1884 1885 /* R845 : case-value */ 1886 case-value: expr 1887 ; 1888 1889 /* R854 : continue-stmt */ 1890 continue-stmt: TOK_CONTINUE 1891 ; 1892 1893 /* R1001 : format-stmt */ 1894 format-stmt: TOK_FORMAT 1895 ; 1896 1897 word_endsubroutine : 1898 TOK_ENDSUBROUTINE 1899 { 1900 strcpy($$,$1); 1901 pos_endsubroutine = setposcur()-strlen($1); 1902 functiondeclarationisdone = 0; 1903 } 1904 ; 1905 word_endunit : 1906 TOK_ENDUNIT 1907 { 1908 strcpy($$,$1); 1909 pos_endsubroutine = setposcur()-strlen($1); 1910 } 1911 ; 1912 word_endprogram : 1913 TOK_ENDPROGRAM 1914 { 1915 strcpy($$,$1); 1916 pos_endsubroutine = setposcur()-strlen($1); 1917 } 1918 ; 1919 word_endfunction : 1920 TOK_ENDFUNCTION 1921 { 1922 strcpy($$,$1); 1923 pos_endsubroutine = setposcur()-strlen($1); 1924 } 1925 ; 4649 line-break 4650 ; 4651 4652 /* R1243 : stmt-function-stmt */ 4653 stmt-function-stmt: TOK_NAME '(' opt-dummy-arg-name-list ')' '=' expr line-break 4654 ; 1926 4655 1927 4656 opt_name : '\n' {strcpy($$,"");} … … 1975 4704 | callarglist 1976 4705 ; 1977 keywordcall 4706 keywordcall: 1978 4707 before_call TOK_FLUSH 1979 4708 | before_call TOK_NAME … … 2000 4729 ; 2001 4730 before_call : TOK_CALL { pos_curcall=setposcur()-4; } 4731 | label TOK_CALL { pos_curcall=setposcur()-4; } 2002 4732 ; 2003 4733 callarglist : … … 2021 4751 ; 2022 4752 2023 option_inlist : 2024 | inlist 2025 ; 2026 option_read : 2027 ioctl option_inlist 2028 | infmt opt_inlist 2029 ; 2030 opt_inlist : 2031 | ',' inlist 2032 ; 4753 option_io_1 : 4754 infmt ',' inlist 4755 | infmt 4756 4757 option_io_2 : 4758 ioctl outlist 4759 | ioctl 4760 2033 4761 ioctl : '(' ctllist ')' 2034 4762 ; … … 2058 4786 ; 2059 4787 iofctl : 2060 TOK_OPEN 2061 | TOK_CLOSE 2062 | TOK_FLUSH 4788 TOK_FLUSH 2063 4789 ; 2064 4790 infmt : unpar_fexpr … … 2066 4792 ; 2067 4793 2068 read : TOK_READ 2069 | TOK_INQUIRE 2070 | TOK_PRINT 4794 write_or_inq : 4795 TOK_WRITE 2071 4796 ; 2072 4797
Note: See TracChangeset
for help on using the changeset viewer.