3 $Id: gram.y 23065 2016-03-02 09:05:50Z coelho $
5 Copyright 1989-2016 MINES ParisTech
7 This file is part of PIPS.
9 PIPS is free software: you can redistribute it and/or modify it
10 under the terms of the GNU General Public License as published by
11 the Free Software Foundation, either version 3 of the License, or
14 PIPS is distributed in the hope that it will be useful, but WITHOUT ANY
15 WARRANTY; without even the implied warranty of MERCHANTABILITY or
16 FITNESS FOR A PARTICULAR PURPOSE.
18 See the GNU General Public License for more details.
20 You should have received a copy of the GNU General Public License
21 along with PIPS. If not, see <http://www.gnu.org/licenses/>.
25 /* PIPS project: syntactic analyzer
29 * Warning: do not use user_error() when processing must be interrupted,
30 * but ParserError() which fixes global variables and leaves a consistent
31 * symbol table. Use user_warning() to display additional information if
32 * ParserError() is too terse.
35 * - IO control info list should be checked; undected errors are likely
36 * to induce core dumps in effects computation; Francois Irigoin;
37 * - Type declarations are not enforced thoroughly: the syntax for characters
38 * is extended to other types; for instance REAL*4 X*40 is syntactically
39 * accepted but "*40" is ignored; Francois Irigoin;
42 * - bug correction for REWIND, BACKSPACE and ENDFILE; improved error
43 * detection in IO statement; Francois Irigoin;
44 * - add DOUBLE PRECISION as a type; Francois Irigoin;
45 * - update length declaration computation for CHARACTER type; the second
46 * length declaration was ignored; for instance:
48 * was interpreted as the declaration of two strings of 3 characters;
49 * two variables added: CurrentType and CurrentTypeSize
51 * - bug with EXTERNAL: CurrentType was not reset to type_undefined
52 * - Complex constants were not recognized; the rule for expression
53 * were modified and a new rule, sous-expression, was added, as well
54 * as a rule for complex constants; Francois Irigoin, 9 January 1992
55 * - global variables should be allocated whenever possible in a different
56 * name space than local variables; their package name should be the
57 * top level name; that would let us accept variables and commons
58 * with the same name and that would make the link edit step easier;
59 * lots of things have to be changed:
61 * global_entity_name: should produce a global entity
63 * common_name: should allocate the blank common in the global space
65 * call_inst: has to refer to a global entity
67 * module_name: has to be allocated in the global space
69 * intrinsic_inst: has to require global_entity_name(s) as parameters
71 * external inst: has to require global_entity_name(s) as parameters
73 * This implies that COMMON are globals to all procedure. The SAVE
74 * statement on COMMONs is meaningless
75 * - add common_size_table to handle COMMONs as global variables;
76 * see declarations.c (Francois Irigoin, 22 January 1992)
77 * - remove complex constant detection because this conflicts with
82 %type <dimension> dim_tableau
84 %type <entity> entity_name
85 %type <entity> global_entity_name
86 %type <entity> functional_entity_name
87 /* %type <entity> module_name */
88 %type <string> module_name
89 %type <entity> common_name
90 %type <entity> declaration
91 %type <entity> common_inst
92 %type <entity> oper_rela
93 %type <entity> unsigned_const_simple
94 %type <expression> const_simple
95 %type <expression> sous_expression
96 %type <expression> expression
97 %type <expression> io_expr
98 %type <expression> unpar_io_expr
99 %type <expression> io_elem
100 %type <expression> io_f_u_id
101 %type <expression> opt_expression
102 %type <instruction> inst_exec
103 %type <instruction> format_inst
104 %type <instruction> data_inst
105 %type <instruction> assignment_inst
106 %type <instruction> goto_inst
107 %type <instruction> arithmif_inst
108 %type <instruction> logicalif_inst
109 %type <instruction> blockif_inst
110 %type <instruction> elseif_inst
111 %type <instruction> else_inst
112 %type <instruction> endif_inst
113 %type <instruction> enddo_inst
114 %type <instruction> do_inst
115 %type <instruction> bdo_inst
116 %type <instruction> wdo_inst
117 %type <instruction> continue_inst
118 %type <instruction> stop_inst
119 %type <instruction> pause_inst
120 %type <instruction> call_inst
121 %type <instruction> return_inst
122 %type <instruction> io_inst
123 %type <instruction> entry_inst
124 %type <integer> io_keyword
126 %type <integer> opt_signe
127 %type <integer> psf_keyword
128 %type <integer> iobuf_keyword
129 %type <integer> signe
130 %type <liste> decl_tableau
131 %type <liste> indices
132 %type <liste> parameters
133 %type <liste> arguments
136 %type <liste> ldim_tableau
137 %type <liste> ldataval
138 %type <liste> ldatavar
139 %type <liste> lexpression
140 %type <liste> lformalparameter
142 %type <liste> lio_elem
143 %type <liste> opt_lformalparameter
144 %type <liste> opt_lio_elem
145 %type <range> do_plage
148 %type <string> global_name
150 %type <tag> fortran_basic_type
151 %type <type> fortran_type
152 %type <type> opt_fortran_type
153 %type <value> lg_fortran_type
154 %type <character> letter
155 %type <expression> dataconst
156 %type <expression> dataval
157 %type <expression> datavar
158 %type <expression> dataidl
162 #include "pips_config.h"
169 #include "parser_private.h"
175 #include "properties.h"
179 #define YYERROR_VERBOSE 1 /* much clearer error messages with bison */
181 /* local variables */
182 int ici; /* to count control specifications in IO statements */
183 type CurrentType = type_undefined; /* the type in a type or dimension
184 or common statement */
185 intptr_t CurrentTypeSize; /* number of bytes to store a value of that type */
187 /* functions for DATA */
189 static expression MakeDataValueSet(expression n, expression c)
191 expression repeat_factor = expression_undefined;
192 expression value_set = expression_undefined;
193 entity repeat_value = FindEntity(TOP_LEVEL_MODULE_NAME,
195 value vc = value_undefined;
197 pips_assert("Function repeat value is defined", !entity_undefined_p(repeat_value));
199 vc = EvalExpression(c);
200 if (! value_constant_p(vc)) {
201 if(!complex_constant_expression_p(c)) {
202 ParserError("MakeDataValueSet", "data value must be a constant\n");
206 if(expression_undefined_p(n)) {
210 repeat_factor = (n == expression_undefined) ? int_to_expression(1) : n;
211 value_set = make_call_expression(repeat_value,
212 CONS(EXPRESSION, repeat_factor,
213 CONS(EXPRESSION, c, NIL)));
220 /* Specify precedences and associativies. */
228 %nonassoc TK_LT TK_GT TK_LE TK_GE TK_EQ TK_NE
230 %left TK_PLUS TK_MINUS
231 %left TK_STAR TK_SLASH
245 expression expression;
246 instruction instruction;
260 { FatalError("parser",
261 "Multiple modules in one file! Check fsplit!");}
264 prg_exec: begin_inst {reset_first_statement();} linstruction { check_first_statement();} end_inst
265 | begin_inst {reset_first_statement(); check_first_statement();} end_inst
268 begin_inst: opt_fortran_type psf_keyword module_name
269 opt_lformalparameter TK_EOS
271 MakeCurrentFunction($1, $2, $3, $4);
275 entry_inst: TK_ENTRY entity_name opt_lformalparameter
277 /* In case the entry is a FUNCTION, you want to recover its type.
278 * You cannot use entity_functional_name as second rule element.
280 if(get_bool_property("PARSER_SUBSTITUTE_ENTRIES")) {
281 $$ = MakeEntry($2, $3);
284 ParserError("Syntax", "ENTRY are not directly processed. "
285 "Set property PARSER_SUBSTITUTE_ENTRIES to allow "
286 "entry substitutions");
291 end_inst: TK_END TK_EOS
292 { EndOfProcedure(); }
297 | linstruction instruction TK_EOS
302 { /* can appear anywhere in specs and execs! */
303 if (first_executable_statement_seen())
305 /* the DATA string to be added to declarations...
306 * however, the information is not really available.
307 * as a hack, I'll try to append the Stmt buffer, but it
308 * has already been processed, thus it is quite far
309 * from the initial statement, and may be incorrect.
310 * I think that this parser is a mess;-) FC.
313 "DATA as an executable statement, moved up...\n");
314 append_data_current_stmt_buffer_to_declarations();
317 /* See if we could save the DATA statements somewhere */
318 /* dump_current_statement(); */
321 | { check_in_declarations();} inst_spec
322 | { check_first_statement();} inst_exec
324 if ($2 != instruction_undefined)
325 LinkInstToCurrentBlock($2, true);
329 LinkInstToCurrentBlock($1, true);
333 inst_spec: parameter_inst
345 inst_exec: assignment_inst
358 { $$ = instruction_undefined; }
360 { $$ = instruction_undefined; }
362 { $$ = instruction_undefined; }
364 { $$ = instruction_undefined; }
366 { $$ = instruction_undefined; }
368 { $$ = instruction_undefined; }
385 return_inst: TK_RETURN opt_expression
386 { $$ = MakeReturn($2); }
389 call_inst: tk_call functional_entity_name
390 { $$ = MakeCallInst($2, NIL); reset_alternate_returns();}
392 tk_call functional_entity_name parameters
393 { $$ = MakeCallInst($2, $3); reset_alternate_returns(); }
397 { set_alternate_returns();}
400 parameters: TK_LPAR TK_RPAR
402 | TK_LPAR arguments TK_RPAR
406 arguments: expression
408 $$ = CONS(EXPRESSION, $1, NIL);
410 | arguments TK_COMMA expression
412 $$ = gen_nconc($1, CONS(EXPRESSION, $3, NIL));
416 add_alternate_return($2);
417 $$ = CONS(EXPRESSION,
418 generate_string_for_alternate_return_argument($2),
421 | arguments TK_COMMA TK_STAR TK_ICON
423 add_alternate_return($4);
424 $$ = gen_nconc($1, CONS(EXPRESSION,
425 generate_string_for_alternate_return_argument($4),
431 io_inst: io_keyword io_f_u_id /* io_keyword io_f_u_id */
433 $$ = MakeSimpleIoInst1($1, $2);
435 | io_keyword io_f_u_id TK_COMMA opt_lio_elem
437 $$ = MakeSimpleIoInst2($1, $2, $4);
439 | io_keyword TK_LPAR lci TK_RPAR opt_virgule opt_lio_elem
440 { $$ = MakeIoInstA($1, $3, $6); }
441 | iobuf_keyword TK_LPAR io_f_u_id TK_COMMA io_f_u_id TK_RPAR
442 TK_LPAR unpar_io_expr TK_COMMA unpar_io_expr TK_RPAR
443 { $$ = MakeIoInstB($1, $3, $5, $8, $10); }
446 io_f_u_id: unpar_io_expr
448 { $$ = MakeNullaryCall(CreateIntrinsic(LIST_DIRECTED_FORMAT_NAME)); }
459 $$ = gen_nconc($1, $3);
463 /* ci: name TK_EQUALS io_f_u_id */
464 ci: name TK_EQUALS unpar_io_expr
467 (void) strcpy(buffer, $1);
470 if(strcmp(buffer,"END")==0||strcmp(buffer,"ERR")==0) {
474 (void) strcat(buffer, "=");
476 $$ = CONS(EXPRESSION,
477 MakeCharacterConstantExpression(buffer),
478 CONS(EXPRESSION, $3, NULL));
481 | name TK_EQUALS TK_STAR
484 (void) strcpy(buffer, $1);
487 if(strcmp(buffer,"UNIT")!=0 && strcmp(buffer,"FMT")!=0) {
488 ParserError("parser",
489 "Illegal default option '*' in IO control list\n");
492 (void) strcat(buffer, "=");
494 $$ = CONS(EXPRESSION,
495 MakeCharacterConstantExpression(buffer),
497 MakeNullaryCall(CreateIntrinsic(LIST_DIRECTED_FORMAT_NAME))
503 if(ici==1 || ici==2) {
504 $$ = CONS(EXPRESSION,
505 MakeCharacterConstantExpression(ici == 1 ?
508 CONS(EXPRESSION, $1, NULL));
511 ParserError("Syntax", "The unit identifier and the format identifier"
512 " must be first and second in the control info list (standard Page F-12)");
522 { $$ = MakeIoList($1); }
526 { $$ = CONS(EXPRESSION, $1, NULL); }
527 | lio_elem TK_COMMA io_elem
528 { $$ = CONS(EXPRESSION, $3, $1); }
535 pause_inst: TK_PAUSE opt_expression
536 { $$ = MakeZeroOrOneArgCallInst("PAUSE", $2); }
539 stop_inst: TK_STOP opt_expression
540 { $$ = MakeZeroOrOneArgCallInst("STOP", $2); }
543 continue_inst: TK_CONTINUE
544 { $$ = MakeZeroOrOneArgCallInst("CONTINUE", expression_undefined);}
547 do_inst: TK_DO label opt_virgule atom do_plage
549 MakeDoInst($4, $5, $2);
550 $$ = instruction_undefined;
554 bdo_inst: TK_DO atom do_plage
556 MakeDoInst($2, $3, "BLOCKDO");
557 $$ = instruction_undefined;
561 wdo_inst: TK_DO TK_WHILE TK_LPAR expression TK_RPAR
563 if(expression_implied_do_p($4))
564 ParserError("Syntax", "Unexpected implied DO\n");
565 MakeWhileDoInst($4, "BLOCKDO");
566 $$ = instruction_undefined;
568 | TK_DO label TK_WHILE TK_LPAR expression TK_RPAR
570 if(expression_implied_do_p($5))
571 ParserError("Syntax", "Unexpected implied DO\n");
572 MakeWhileDoInst($5, $2);
573 $$ = instruction_undefined;
577 do_plage: TK_EQUALS expression TK_COMMA expression
579 if(expression_implied_do_p($2) || expression_implied_do_p($4))
580 ParserError("Syntax", "Unexpected implied DO\n");
581 $$ = make_range($2, $4, int_to_expression(1));
583 | TK_EQUALS expression TK_COMMA expression TK_COMMA expression
585 if(expression_implied_do_p($2) || expression_implied_do_p($4)
586 || expression_implied_do_p($6))
587 ParserError("Syntax", "Unexpected implied DO\n");
588 $$ = make_range($2, $4, $6);
601 { MakeElseInst(true); }
604 elseif_inst: TK_ELSEIF TK_LPAR expression TK_RPAR TK_THEN
606 int elsifs = MakeElseInst(false);
608 if(expression_implied_do_p($3))
609 ParserError("Syntax", "Unexpected implied DO\n");
610 MakeBlockIfInst( $3, elsifs+1 );
611 $$ = instruction_undefined;
615 blockif_inst: TK_IF TK_LPAR expression TK_RPAR TK_THEN
617 if(expression_implied_do_p($3))
618 ParserError("Syntax", "Unexpected implied DO\n");
619 MakeBlockIfInst($3,0);
620 $$ = instruction_undefined;
624 logicalif_inst: TK_IF TK_LPAR expression TK_RPAR inst_exec
626 if(expression_implied_do_p($3))
627 ParserError("Syntax", "Unexpected implied DO\n");
628 $$ = MakeLogicalIfInst($3, $5);
632 arithmif_inst: TK_IF TK_LPAR expression TK_RPAR
633 label TK_COMMA label TK_COMMA label
635 if(expression_implied_do_p($3))
636 ParserError("Syntax", "Unexpected implied DO\n");
637 $$ = MakeArithmIfInst($3, $5, $7, $9);
641 goto_inst: TK_GOTO label
643 $$ = MakeGotoInst($2);
645 | TK_GOTO TK_LPAR licon TK_RPAR opt_virgule expression
647 if(expression_implied_do_p($6))
648 ParserError("Syntax", "Unexpected implied DO\n");
649 $$ = MakeComputedGotoInst($3, $6);
651 | TK_GOTO entity_name opt_virgule TK_LPAR licon TK_RPAR
653 if(get_bool_property("PARSER_SUBSTITUTE_ASSIGNED_GOTO")) {
654 $$ = MakeAssignedGotoInst($5, $2);
657 ParserError("parser", "assigned goto statement prohibited"
658 " unless property PARSER_SUBSTITUTE_ASSIGNED_GOTO is set\n");
661 | TK_GOTO entity_name
663 if(get_bool_property("PARSER_SUBSTITUTE_ASSIGNED_GOTO")) {
664 ParserError("parser", "assigned goto statement cannot be"
665 " desugared without a target list\n");
668 ParserError("parser", "assigned goto statement prohibited\n");
675 $$ = CONS(STRING, $1, NIL);
677 | licon TK_COMMA label
679 $$ = CONS(STRING, $3, $1);
683 assignment_inst: TK_ASSIGN icon TK_TO atom
685 if(get_bool_property("PARSER_SUBSTITUTE_ASSIGNED_GOTO")) {
686 expression e = entity_to_expression($2);
687 $$ = MakeAssignInst($4, e);
690 ParserError("parser", "ASSIGN statement prohibited by PIPS"
691 " unless property PARSER_SUBSTITUTE_ASSIGNED_GOTO is set\n");
694 | atom TK_EQUALS expression
697 syntax new_s = syntax_undefined;
699 if(expression_implied_do_p($3))
700 ParserError("Syntax", "Unexpected implied DO\n");
702 new_s = CheckLeftHandSide(s);
704 $$ = MakeAssignInst(new_s, $3);
708 format_inst: TK_FORMAT
710 set_first_format_statement();
711 $$ = MakeZeroOrOneArgCallInst("FORMAT",
712 MakeCharacterConstantExpression(FormatValue));
717 { save_all_entities(); }
719 | TK_STATIC lsavename
723 | lsavename TK_COMMA savename
726 savename: entity_name
732 intrinsic_inst: TK_INTRINSIC global_entity_name
734 (void) DeclareIntrinsic($2);
736 | intrinsic_inst TK_COMMA global_entity_name
738 (void) DeclareIntrinsic($3);
742 external_inst: TK_EXTERNAL functional_entity_name
744 CurrentType = type_undefined;
745 (void) DeclareExternalFunction($2);
747 | external_inst TK_COMMA functional_entity_name
749 (void) DeclareExternalFunction($3);
753 type_inst: fortran_type declaration
755 | type_inst TK_COMMA declaration
758 declaration: entity_name decl_tableau lg_fortran_type
760 /* the size returned by lg_fortran_type should be
761 consistent with CurrentType unless it is of type string
763 type t = CurrentType;
765 if(t != type_undefined) {
768 if(!type_variable_p(CurrentType))
769 FatalError("yyparse", "ill. type for CurrentType\n");
771 b = variable_basic(type_variable(CurrentType));
773 /* character [*len1] foo [*len2]:
774 * if len2 is "default" then len1
776 if(basic_string_p(b))
777 t = value_intrinsic_p($3)? /* ??? default */
780 (make_basic(is_basic_string, $3), NIL);
782 DeclareVariable($1, t, $2,
783 storage_undefined, value_undefined);
785 if(basic_string_p(b))
789 DeclareVariable($1, t, $2,
790 storage_undefined, value_undefined);
800 | TK_LPAR ldim_tableau TK_RPAR
806 ldim_tableau: dim_tableau
808 $$ = CONS(DIMENSION, $1, NULL);
810 | dim_tableau TK_COMMA ldim_tableau
812 $$ = CONS(DIMENSION, $1, $3);
816 dim_tableau: expression
819 type t = expression_to_type(e);
820 if(scalar_integer_type_p(t))
821 $$ = make_dimension(int_to_expression(1), e, NIL);
822 else // Not OK with gfortran, maybe OK with f77
823 ParserError("Syntax",
824 "Array sized with a non-integer expression");
829 $$ = make_dimension(int_to_expression(1),
830 MakeNullaryCall(CreateIntrinsic(UNBOUNDED_DIMENSION_NAME)),
833 | expression TK_COLON TK_STAR
835 $$ = make_dimension($1,
836 MakeNullaryCall(CreateIntrinsic(UNBOUNDED_DIMENSION_NAME)),
839 | expression TK_COLON expression
842 type t1 = expression_to_type(e1);
844 type t2 = expression_to_type(e2);
845 if(scalar_integer_type_p(t1) && scalar_integer_type_p(t2))
846 $$ = make_dimension(e1, e2, NIL);
847 else // Not OK with gfortran, maybe OK with f77
848 ParserError("Syntax",
849 "Array sized with a non-integer expression");
850 free_type(t1), free_type(t2);
854 common_inst: common declaration
856 $$ = NameToCommon(BLANK_COMMON_LOCAL_NAME);
857 AddVariableToCommon($$, $2);
859 | common common_name declaration
862 AddVariableToCommon($$, $3);
864 | common_inst TK_COMMA declaration
867 AddVariableToCommon($$, $3);
869 | common_inst opt_virgule common_name declaration
872 AddVariableToCommon($$, $4);
879 CurrentType = type_undefined;
883 common_name: TK_CONCAT
885 $$ = NameToCommon(BLANK_COMMON_LOCAL_NAME);
887 | TK_SLASH global_name TK_SLASH
889 $$ = NameToCommon($2);
893 pointer_inst: TK_POINTER TK_LPAR entity_name TK_COMMA entity_name decl_tableau TK_RPAR
895 DeclarePointer($3, $5, $6);
899 equivalence_inst: TK_EQUIVALENCE lequivchain
902 lequivchain: equivchain
903 | lequivchain TK_COMMA equivchain
906 equivchain: TK_LPAR latom TK_RPAR
907 { StoreEquivChain($2); }
912 $$ = make_chain(CONS(ATOM, MakeEquivAtom($1), (cons*) NULL));
914 | latom TK_COMMA atom
916 chain_atoms($1) = CONS(ATOM, MakeEquivAtom($3),
922 dimension_inst: dimension declaration
925 | dimension_inst TK_COMMA declaration
930 dimension: TK_DIMENSION
932 CurrentType = type_undefined;
936 data_inst: TK_DATA ldatavar TK_SLASH ldataval TK_SLASH
938 /* AnalyzeData($2, $4); */
939 MakeDataStatement($2, $4);
941 | data_inst opt_virgule ldatavar TK_SLASH ldataval TK_SLASH
943 /* AnalyzeData($3, $5); */
944 MakeDataStatement($3, $5);
950 $$ = CONS(EXPRESSION, $1, NIL);
952 | ldatavar TK_COMMA datavar
954 $$ = gen_nconc($1, CONS(EXPRESSION, $3, NIL));
958 /* rule reversal because of a stack overflow; bug hit.f */
961 $$ = CONS(EXPRESSION, $1, NIL);
963 | ldataval TK_COMMA dataval
965 $$ = gen_nconc($1, CONS(EXPRESSION, $3, NIL));
971 $$ = MakeDataValueSet(expression_undefined, $1);
973 | dataconst TK_STAR dataconst
975 $$ = MakeDataValueSet($1, $3);
979 dataconst: const_simple /* expression -> shift/reduce conflicts */
983 | TK_LPAR const_simple TK_COMMA const_simple TK_RPAR
985 $$ = MakeComplexConstantExpression($2, $4);
989 /* Cachan bug 4: there should be a check about the entity
990 * returned as $1 because MakeDatVal() is going to try
991 * to evaluate that expression. The entity must be a
994 if(symbolic_constant_entity_p($1)) {
995 $$ = make_expression(make_syntax(is_syntax_call,
997 normalized_undefined);
1000 user_warning("gram", "Symbolic constant expected: %s\n",
1001 entity_local_name($1));
1002 if(strcmp("Z", entity_local_name($1))==0) {
1003 user_warning("gram",
1004 "Might be a non supported hexadecimal constant\n");
1006 ParserError("gram", "Error in initializer");
1010 | entity_name TK_LPAR const_simple TK_COMMA const_simple TK_RPAR
1012 bool simple = ENTITY_IMPLIED_CMPLX_P($1);
1013 pips_assert("is implied complex",
1014 simple || ENTITY_IMPLIED_DCMPLX_P($1) );
1015 $$ = MakeBinaryCall(CreateIntrinsic
1016 (simple? IMPLIED_COMPLEX_NAME: IMPLIED_DCOMPLEX_NAME), $3, $5);
1023 $$ = make_expression($1, normalized_undefined);
1029 dataidl: TK_LPAR ldatavar TK_COMMA entity_name do_plage TK_RPAR
1031 /* $$ = MakeDataVar($2, $5); */
1032 reference r = make_reference($4, NIL);
1033 syntax s = make_syntax(is_syntax_reference, r);
1034 $$ = MakeImpliedDo(s, $5, $2);
1038 implicit_inst: TK_IMPLICIT limplicit
1040 /* Formal parameters have inherited default implicit types */
1041 retype_formal_parameters();
1048 | limplicit TK_COMMA implicit
1053 implicit: fortran_type TK_LPAR l_letter_letter TK_RPAR
1058 l_letter_letter: letter_letter
1061 | l_letter_letter TK_COMMA letter_letter
1066 letter_letter: letter
1070 pips_assert("gram.y", type_variable_p(CurrentType));
1071 b = variable_basic(type_variable(CurrentType));
1073 cr_implicit(basic_tag(b), SizeOfElements(b), $1, $1);
1075 | letter TK_MINUS letter
1079 pips_assert("gram.y", type_variable_p(CurrentType));
1080 b = variable_basic(type_variable(CurrentType));
1082 cr_implicit(basic_tag(b), SizeOfElements(b), $1, $3);
1088 $$ = $1[0]; free($1);
1092 parameter_inst: TK_PARAMETER TK_LPAR lparametre TK_RPAR
1095 lparametre: parametre
1096 | lparametre TK_COMMA parametre
1099 parametre: entity_name TK_EQUALS expression
1101 AddEntityToDeclarations(MakeParameter($1, $3), get_current_module_entity());
1107 /* malloc_verify(); */
1108 /* if SafeFind were always used, intrinsic would mask local
1109 variables, either when the module declarations are not
1110 available or when a new entity still has to be
1111 declared. See Validation/capture01.f */
1112 /* Let's try not to search intrinsics in SafeFindOrCreateEntity(). */
1113 /* Do not declare undeclared variables, because it generates
1114 a problem when processing entries. */
1115 /* $$ = SafeFindOrCreateEntity(CurrentPackage, $1); */
1117 if(!entity_undefined_p(get_current_module_entity())) {
1118 $$ = SafeFindOrCreateEntity(CurrentPackage, $1);
1119 /* AddEntityToDeclarations($$, get_current_module_entity()); */
1122 $$ = FindOrCreateEntity(CurrentPackage, $1);
1131 module_name: global_name
1133 /* $$ = FindOrCreateEntity(CurrentPackage, $1); */
1134 /* $$ = FindOrCreateEntity(TOP_LEVEL_MODULE_NAME, $1); */
1135 CurrentPackage = strdup($1);
1136 BeginingOfProcedure();
1138 $$ = (char*)CurrentPackage;
1142 global_entity_name: global_name
1144 /* $$ = FindOrCreateEntity(CurrentPackage, $1); */
1145 $$ = FindOrCreateEntity(TOP_LEVEL_MODULE_NAME, $1);
1150 functional_entity_name: name
1152 /* This includes BLOCKDATA modules because of EXTERNAL */
1153 $$ = NameToFunctionalEntity($1);
1158 global_name: TK_NAME
1162 opt_lformalparameter:
1170 | TK_LPAR lformalparameter TK_RPAR
1172 /* Too early: the current module is still unknown */
1173 /* $$ = add_formal_return_code($2); */
1178 lformalparameter: entity_name
1180 $$ = CONS(ENTITY, $1, NULL);
1184 uses_alternate_return(true);
1186 generate_pseudo_formal_variable_for_formal_label
1187 (CurrentPackage, get_current_number_of_alternate_returns()),
1190 | lformalparameter TK_COMMA entity_name
1192 $$ = gen_nconc($1, CONS(ENTITY, $3, NIL));
1194 | lformalparameter TK_COMMA TK_STAR
1196 uses_alternate_return(true);
1197 $$ = gen_nconc($1, CONS(ENTITY,
1198 generate_pseudo_formal_variable_for_formal_label
1199 (CurrentPackage, get_current_number_of_alternate_returns()),
1204 opt_fortran_type: fortran_type
1206 $$ = CurrentType = $1 ;
1210 $$ = CurrentType = type_undefined;
1214 fortran_type: fortran_basic_type lg_fortran_type
1216 if (value_intrinsic_p($2)) /* ??? default! */
1219 $2 = make_value_constant(
1220 make_constant_int( CurrentTypeSize));
1223 $$ = CurrentType = MakeFortranType($1, $2);
1227 fortran_basic_type: TK_INTEGER
1230 CurrentTypeSize = DEFAULT_INTEGER_TYPE_SIZE;
1234 $$ = is_basic_float;
1235 CurrentTypeSize = DEFAULT_REAL_TYPE_SIZE;
1237 | TK_DOUBLEPRECISION
1239 $$ = is_basic_float;
1240 CurrentTypeSize = DEFAULT_DOUBLEPRECISION_TYPE_SIZE;
1244 $$ = is_basic_logical;
1245 CurrentTypeSize = DEFAULT_LOGICAL_TYPE_SIZE;
1249 $$ = is_basic_complex;
1250 CurrentTypeSize = DEFAULT_COMPLEX_TYPE_SIZE;
1254 $$ = is_basic_complex;
1255 CurrentTypeSize = DEFAULT_DOUBLECOMPLEX_TYPE_SIZE;
1259 $$ = is_basic_string;
1260 CurrentTypeSize = DEFAULT_CHARACTER_TYPE_SIZE;
1266 $$ = make_value(is_value_intrinsic, UU); /* ??? default! */
1267 /* was: $$ = make_value(is_value_constant,
1268 * make_constant(is_constant_int, CurrentTypeSize));
1269 * then how to differentiate character*len1 foo[*len2]
1270 * if len2 is 1 or whatever... the issue is that
1271 * there should be two lg_..., one for the default that
1272 * would change CurrentTypeSize at ival, and the other not...
1276 | TK_STAR TK_LPAR TK_STAR TK_RPAR /* CHARACTER *(*) */
1278 $$ = make_value_unknown();
1280 | TK_STAR TK_LPAR expression TK_RPAR
1282 $$ = MakeValueSymbolic($3);
1286 $$ = make_value_constant(make_constant_int($2));
1292 $$ = MakeAtom($1, NIL, expression_undefined,
1293 expression_undefined, false);
1295 | entity_name indices
1297 $$ = MakeAtom($1, $2, expression_undefined,
1298 expression_undefined, true);
1300 | entity_name TK_LPAR opt_expression TK_COLON opt_expression TK_RPAR
1302 $$ = MakeAtom($1, NIL, $3, $5, true);
1304 | entity_name indices TK_LPAR opt_expression TK_COLON opt_expression TK_RPAR
1306 $$ = MakeAtom($1, $2, $4, $6, true);
1310 indices: TK_LPAR TK_RPAR
1312 | TK_LPAR lexpression TK_RPAR
1313 { $$ = FortranExpressionList($2); }
1316 lexpression: expression
1318 $$ = CONS(EXPRESSION, $1, NULL);
1320 | lexpression TK_COMMA expression
1322 $$ = gen_nconc($1, CONS(EXPRESSION, $3, NIL));
1326 opt_expression: expression
1328 if(expression_implied_do_p($1))
1329 ParserError("Syntax", "Unexpected implied DO\n");
1333 { $$ = expression_undefined; }
1336 expression: sous_expression
1338 | TK_LPAR expression TK_RPAR
1340 | TK_LPAR expression TK_COMMA expression TK_RPAR
1342 expression c = MakeComplexConstantExpression($2, $4);
1344 if(expression_undefined_p(c))
1345 ParserError("Syntax", "Illegal complex constant\n");
1349 | TK_LPAR expression TK_COMMA atom do_plage TK_RPAR
1350 { $$ = MakeImpliedDo($4, $5, CONS(EXPRESSION, $2, NIL)); }
1351 | TK_LPAR expression TK_COMMA lexpression TK_COMMA atom do_plage TK_RPAR
1352 { $$ = MakeImpliedDo($6, $7, CONS(EXPRESSION, $2, $4)); }
1355 sous_expression: atom
1357 $$ = make_expression($1, normalized_undefined);
1359 | unsigned_const_simple
1361 $$ = MakeNullaryCall($1);
1363 | signe expression %prec TK_STAR
1366 $$ = MakeFortranUnaryCall(CreateIntrinsic("--"), $2);
1370 | expression TK_PLUS expression
1372 $$ = MakeFortranBinaryCall(CreateIntrinsic("+"), $1, $3);
1374 | expression TK_MINUS expression
1376 $$ = MakeFortranBinaryCall(CreateIntrinsic("-"), $1, $3);
1378 | expression TK_STAR expression
1380 $$ = MakeFortranBinaryCall(CreateIntrinsic("*"), $1, $3);
1382 | expression TK_SLASH expression
1384 $$ = MakeFortranBinaryCall(CreateIntrinsic("/"), $1, $3);
1386 | expression TK_POWER expression
1388 $$ = MakeFortranBinaryCall(CreateIntrinsic("**"),
1391 | expression oper_rela expression %prec TK_EQ
1393 $$ = MakeFortranBinaryCall($2, $1, $3);
1395 | expression TK_EQV expression
1397 $$ = MakeFortranBinaryCall(CreateIntrinsic(".EQV."),
1400 | expression TK_NEQV expression
1402 $$ = MakeFortranBinaryCall(CreateIntrinsic(".NEQV."),
1405 | expression TK_OR expression
1407 $$ = MakeFortranBinaryCall(CreateIntrinsic(".OR."),
1408 fix_if_condition($1),
1409 fix_if_condition($3));
1411 | expression TK_AND expression
1413 $$ = MakeFortranBinaryCall(CreateIntrinsic(".AND."),
1414 fix_if_condition($1),
1415 fix_if_condition($3));
1419 $$ = MakeFortranUnaryCall(CreateIntrinsic(".NOT."),
1420 fix_if_condition($2));
1422 | expression TK_CONCAT expression
1424 $$ = MakeFortranBinaryCall(CreateIntrinsic("//"),
1429 io_expr: unpar_io_expr
1430 | TK_LPAR io_expr TK_RPAR
1436 $$ = make_expression($1, normalized_undefined);
1438 /* | const_simple */
1439 | unsigned_const_simple
1441 $$ = MakeNullaryCall($1);
1443 | signe io_expr %prec TK_STAR
1446 $$ = MakeFortranUnaryCall(CreateIntrinsic("--"), $2);
1450 | io_expr TK_PLUS io_expr
1452 $$ = MakeFortranBinaryCall(CreateIntrinsic("+"), $1, $3);
1454 | io_expr TK_MINUS io_expr
1456 $$ = MakeFortranBinaryCall(CreateIntrinsic("-"), $1, $3);
1458 | io_expr TK_STAR io_expr
1460 $$ = MakeFortranBinaryCall(CreateIntrinsic("*"), $1, $3);
1462 | io_expr TK_SLASH io_expr
1464 $$ = MakeFortranBinaryCall(CreateIntrinsic("/"), $1, $3);
1466 | io_expr TK_POWER io_expr
1468 $$ = MakeFortranBinaryCall(CreateIntrinsic("**"),
1471 | io_expr TK_CONCAT io_expr
1473 $$ = MakeFortranBinaryCall(CreateIntrinsic("//"),
1478 const_simple: opt_signe unsigned_const_simple
1481 $$ = MakeUnaryCall(CreateIntrinsic("--"),
1482 MakeNullaryCall($2));
1484 $$ = MakeNullaryCall($2);
1488 unsigned_const_simple: TK_TRUE
1490 $$ = SafeMakeConstant(".TRUE.", is_basic_logical, ParserError);
1494 $$ = SafeMakeConstant(".FALSE.", is_basic_logical, ParserError);
1502 $$ = make_Fortran_constant_entity($1, is_basic_float,
1503 DEFAULT_DOUBLEPRECISION_TYPE_SIZE);
1508 $$ = SafeMakeConstant($1, is_basic_string, ParserError);
1513 $$ = SafeMakeConstant($1, is_basic_float, ParserError);
1520 $$ = SafeMakeConstant($1, is_basic_int, ParserError);
1560 $$ = CreateIntrinsic(".EQ.");
1564 $$ = CreateIntrinsic(".NE.");
1568 $$ = CreateIntrinsic(".LT.");
1572 $$ = CreateIntrinsic(".LE.");
1576 $$ = CreateIntrinsic(".GE.");
1580 $$ = CreateIntrinsic(".GT.");
1584 io_keyword: TK_PRINT
1585 { $$ = TK_PRINT; ici = 1; }
1587 { $$ = TK_WRITE; ici = 1; }
1589 { $$ = TK_READ; ici = 1; }
1591 { $$ = TK_CLOSE; ici = 1; }
1593 { $$ = TK_OPEN; ici = 1; }
1595 { $$ = TK_ENDFILE; ici = 1; }
1597 { $$ = TK_BACKSPACE; ici = 1; }
1599 { $$ = TK_REWIND; ici = 1; }
1601 { $$ = TK_INQUIRE; ici = 1; }
1604 iobuf_keyword: TK_BUFFERIN
1605 { $$ = TK_BUFFERIN; ici = 1; }
1607 { $$ = TK_BUFFEROUT ; ici = 1; }
1610 psf_keyword: TK_PROGRAM
1611 { $$ = TK_PROGRAM; init_ghost_variable_entities(); }
1613 { $$ = TK_SUBROUTINE; init_ghost_variable_entities();
1614 set_current_number_of_alternate_returns();}
1616 { $$ = TK_FUNCTION; init_ghost_variable_entities();
1617 set_current_number_of_alternate_returns();}
1619 { $$ = TK_BLOCKDATA; init_ghost_variable_entities(); }