/*
$Id$
Copyright 1989-2016 MINES ParisTech
This file is part of PIPS.
PIPS is free software: you can redistribute it and/or modify it
under the terms of the GNU General Public License as published by
the Free Software Foundation, either version 3 of the License, or
any later version.
PIPS is distributed in the hope that it will be useful, but WITHOUT ANY
WARRANTY; without even the implied warranty of MERCHANTABILITY or
FITNESS FOR A PARTICULAR PURPOSE.
See the GNU General Public License for more details.
You should have received a copy of the GNU General Public License
along with PIPS. If not, see .
*/
/* PIPS project: syntactic analyzer
*
* Remi Triolet
*
* Warning: do not use user_error() when processing must be interrupted,
* but ParserError() which fixes global variables and leaves a consistent
* symbol table. Use user_warning() to display additional information if
* ParserError() is too terse.
*
* Bugs:
* - IO control info list should be checked; undected errors are likely
* to induce core dumps in effects computation; Francois Irigoin;
* - Type declarations are not enforced thoroughly: the syntax for characters
* is extended to other types; for instance REAL*4 X*40 is syntactically
* accepted but "*40" is ignored; Francois Irigoin;
*
* Modifications:
* - bug correction for REWIND, BACKSPACE and ENDFILE; improved error
* detection in IO statement; Francois Irigoin;
* - add DOUBLE PRECISION as a type; Francois Irigoin;
* - update length declaration computation for CHARACTER type; the second
* length declaration was ignored; for instance:
* CHARACTER*3 X*56, Y
* was interpreted as the declaration of two strings of 3 characters;
* two variables added: CurrentType and CurrentTypeSize
* Francois Irigoin
* - bug with EXTERNAL: CurrentType was not reset to type_undefined
* - Complex constants were not recognized; the rule for expression
* were modified and a new rule, sous-expression, was added, as well
* as a rule for complex constants; Francois Irigoin, 9 January 1992
* - global variables should be allocated whenever possible in a different
* name space than local variables; their package name should be the
* top level name; that would let us accept variables and commons
* with the same name and that would make the link edit step easier;
* lots of things have to be changed:
*
* global_entity_name: should produce a global entity
*
* common_name: should allocate the blank common in the global space
*
* call_inst: has to refer to a global entity
*
* module_name: has to be allocated in the global space
*
* intrinsic_inst: has to require global_entity_name(s) as parameters
*
* external inst: has to require global_entity_name(s) as parameters
*
* This implies that COMMON are globals to all procedure. The SAVE
* statement on COMMONs is meaningless
* - add common_size_table to handle COMMONs as global variables;
* see declarations.c (Francois Irigoin, 22 January 1992)
* - remove complex constant detection because this conflicts with
* IO statements
*/
%type latom
%type dim_tableau
%type icon
%type entity_name
%type global_entity_name
%type functional_entity_name
/* %type module_name */
%type module_name
%type common_name
%type declaration
%type common_inst
%type oper_rela
%type unsigned_const_simple
%type const_simple
%type sous_expression
%type expression
%type io_expr
%type unpar_io_expr
%type io_elem
%type io_f_u_id
%type opt_expression
%type inst_exec
%type format_inst
%type data_inst
%type assignment_inst
%type goto_inst
%type arithmif_inst
%type logicalif_inst
%type blockif_inst
%type elseif_inst
%type else_inst
%type endif_inst
%type enddo_inst
%type do_inst
%type bdo_inst
%type wdo_inst
%type continue_inst
%type stop_inst
%type pause_inst
%type call_inst
%type return_inst
%type io_inst
%type entry_inst
%type io_keyword
%type ival
%type opt_signe
%type psf_keyword
%type iobuf_keyword
%type signe
%type decl_tableau
%type indices
%type parameters
%type arguments
%type lci
%type ci
%type ldim_tableau
%type ldataval
%type ldatavar
%type lexpression
%type lformalparameter
%type licon
%type lio_elem
%type opt_lformalparameter
%type opt_lio_elem
%type do_plage
%type label
%type name
%type global_name
%type atom
%type fortran_basic_type
%type fortran_type
%type opt_fortran_type
%type lg_fortran_type
%type letter
%type dataconst
%type dataval
%type datavar
%type dataidl
%{
#ifdef HAVE_CONFIG_H
#include "pips_config.h"
#endif
#include
#include
#include
#include "genC.h"
#include "parser_private.h"
#include "linear.h"
#include "ri.h"
#include "ri-util.h"
#include "misc.h"
#include "properties.h"
#include "syntax.h"
#define YYERROR_VERBOSE 1 /* much clearer error messages with bison */
/* local variables */
int ici; /* to count control specifications in IO statements */
type CurrentType = type_undefined; /* the type in a type or dimension
or common statement */
intptr_t CurrentTypeSize; /* number of bytes to store a value of that type */
/* functions for DATA */
static expression MakeDataValueSet(expression n, expression c)
{
expression repeat_factor = expression_undefined;
expression value_set = expression_undefined;
entity repeat_value = FindEntity(TOP_LEVEL_MODULE_NAME,
REPEAT_VALUE_NAME);
value vc = value_undefined;
pips_assert("Function repeat value is defined", !entity_undefined_p(repeat_value));
vc = EvalExpression(c);
if (! value_constant_p(vc)) {
if(!complex_constant_expression_p(c)) {
ParserError("MakeDataValueSet", "data value must be a constant\n");
}
}
if(expression_undefined_p(n)) {
value_set = c;
}
else {
repeat_factor = (n == expression_undefined) ? int_to_expression(1) : n;
value_set = make_call_expression(repeat_value,
CONS(EXPRESSION, repeat_factor,
CONS(EXPRESSION, c, NIL)));
}
return value_set;
}
%}
/* Specify precedences and associativies. */
%left TK_COMMA
%nonassoc TK_COLON
%right TK_EQUALS
%left TK_EQV TK_NEQV
%left TK_OR
%left TK_AND
%left TK_NOT
%nonassoc TK_LT TK_GT TK_LE TK_GE TK_EQ TK_NE
%left TK_CONCAT
%left TK_PLUS TK_MINUS
%left TK_STAR TK_SLASH
%right TK_POWER
%token TK_IOLPAR
%union {
basic basic;
chain chain;
char character;
cons * liste;
dataval dataval;
datavar datavar;
dimension dimension;
entity entity;
expression expression;
instruction instruction;
int integer;
range range;
string string;
syntax syntax;
tag tag;
type type;
value value;
}
%%
lprg_exec: prg_exec
| lprg_exec prg_exec
{ FatalError("parser",
"Multiple modules in one file! Check fsplit!");}
;
prg_exec: begin_inst {reset_first_statement();} linstruction { check_first_statement();} end_inst
| begin_inst {reset_first_statement(); check_first_statement();} end_inst
;
begin_inst: opt_fortran_type psf_keyword module_name
opt_lformalparameter TK_EOS
{
MakeCurrentFunction($1, $2, $3, $4);
}
;
entry_inst: TK_ENTRY entity_name opt_lformalparameter
{
/* In case the entry is a FUNCTION, you want to recover its type.
* You cannot use entity_functional_name as second rule element.
*/
if(get_bool_property("PARSER_SUBSTITUTE_ENTRIES")) {
$$ = MakeEntry($2, $3);
}
else {
ParserError("Syntax", "ENTRY are not directly processed. "
"Set property PARSER_SUBSTITUTE_ENTRIES to allow "
"entry substitutions");
}
}
;
end_inst: TK_END TK_EOS
{ EndOfProcedure(); }
;
linstruction: TK_EOS
| instruction TK_EOS
| linstruction instruction TK_EOS
;
instruction:
data_inst
{ /* can appear anywhere in specs and execs! */
if (first_executable_statement_seen())
{
/* the DATA string to be added to declarations...
* however, the information is not really available.
* as a hack, I'll try to append the Stmt buffer, but it
* has already been processed, thus it is quite far
* from the initial statement, and may be incorrect.
* I think that this parser is a mess;-) FC.
*/
pips_user_warning(
"DATA as an executable statement, moved up...\n");
append_data_current_stmt_buffer_to_declarations();
}
/* See if we could save the DATA statements somewhere */
/* dump_current_statement(); */
}
| { check_in_declarations();} inst_spec
| { check_first_statement();} inst_exec
{
if ($2 != instruction_undefined)
LinkInstToCurrentBlock($2, true);
}
| format_inst
{
LinkInstToCurrentBlock($1, true);
}
;
inst_spec: parameter_inst
| implicit_inst
| dimension_inst
| pointer_inst
| equivalence_inst
| common_inst {}
| type_inst
| external_inst
| intrinsic_inst
| save_inst
;
inst_exec: assignment_inst
{ $$ = $1; }
| goto_inst
{ $$ = $1; }
| arithmif_inst
{ $$ = $1; }
| logicalif_inst
{ $$ = $1; }
| blockif_inst
{ $$ = $1; }
| elseif_inst
{ $$ = $1; }
| else_inst
{ $$ = instruction_undefined; }
| endif_inst
{ $$ = instruction_undefined; }
| enddo_inst
{ $$ = instruction_undefined; }
| do_inst
{ $$ = instruction_undefined; }
| bdo_inst
{ $$ = instruction_undefined; }
| wdo_inst
{ $$ = instruction_undefined; }
| continue_inst
{ $$ = $1; }
| stop_inst
{ $$ = $1; }
| pause_inst
{ $$ = $1; }
| call_inst
{ $$ = $1; }
| return_inst
{ $$ = $1; }
| io_inst
{ $$ = $1; }
| entry_inst
{ $$ = $1; }
;
return_inst: TK_RETURN opt_expression
{ $$ = MakeReturn($2); }
;
call_inst: tk_call functional_entity_name
{ $$ = MakeCallInst($2, NIL); reset_alternate_returns();}
|
tk_call functional_entity_name parameters
{ $$ = MakeCallInst($2, $3); reset_alternate_returns(); }
;
tk_call: TK_CALL
{ set_alternate_returns();}
;
parameters: TK_LPAR TK_RPAR
{ $$ = NULL; }
| TK_LPAR arguments TK_RPAR
{ $$ = $2; }
;
arguments: expression
{
$$ = CONS(EXPRESSION, $1, NIL);
}
| arguments TK_COMMA expression
{
$$ = gen_nconc($1, CONS(EXPRESSION, $3, NIL));
}
| TK_STAR TK_ICON
{
add_alternate_return($2);
$$ = CONS(EXPRESSION,
generate_string_for_alternate_return_argument($2),
NIL);
}
| arguments TK_COMMA TK_STAR TK_ICON
{
add_alternate_return($4);
$$ = gen_nconc($1, CONS(EXPRESSION,
generate_string_for_alternate_return_argument($4),
NIL));
}
;
io_inst: io_keyword io_f_u_id /* io_keyword io_f_u_id */
{
$$ = MakeSimpleIoInst1($1, $2);
}
| io_keyword io_f_u_id TK_COMMA opt_lio_elem
{
$$ = MakeSimpleIoInst2($1, $2, $4);
}
| io_keyword TK_LPAR lci TK_RPAR opt_virgule opt_lio_elem
{ $$ = MakeIoInstA($1, $3, $6); }
| iobuf_keyword TK_LPAR io_f_u_id TK_COMMA io_f_u_id TK_RPAR
TK_LPAR unpar_io_expr TK_COMMA unpar_io_expr TK_RPAR
{ $$ = MakeIoInstB($1, $3, $5, $8, $10); }
;
io_f_u_id: unpar_io_expr
| TK_STAR
{ $$ = MakeNullaryCall(CreateIntrinsic(LIST_DIRECTED_FORMAT_NAME)); }
;
lci: ci
{ $$ = $1; }
| lci TK_COMMA ci
{
/*
CDR(CDR($3)) = $1;
$$ = $3;
*/
$$ = gen_nconc($1, $3);
}
;
/* ci: name TK_EQUALS io_f_u_id */
ci: name TK_EQUALS unpar_io_expr
{
char buffer[20];
(void) strcpy(buffer, $1);
free($1);
if(strcmp(buffer,"END")==0||strcmp(buffer,"ERR")==0) {
;
}
(void) strcat(buffer, "=");
$$ = CONS(EXPRESSION,
MakeCharacterConstantExpression(buffer),
CONS(EXPRESSION, $3, NULL));
ici += 2;
}
| name TK_EQUALS TK_STAR
{
char buffer[20];
(void) strcpy(buffer, $1);
free($1);
if(strcmp(buffer,"UNIT")!=0 && strcmp(buffer,"FMT")!=0) {
ParserError("parser",
"Illegal default option '*' in IO control list\n");
}
(void) strcat(buffer, "=");
$$ = CONS(EXPRESSION,
MakeCharacterConstantExpression(buffer),
CONS(EXPRESSION,
MakeNullaryCall(CreateIntrinsic(LIST_DIRECTED_FORMAT_NAME))
, NULL));
ici += 2;
}
| io_f_u_id
{
if(ici==1 || ici==2) {
$$ = CONS(EXPRESSION,
MakeCharacterConstantExpression(ici == 1 ?
"UNIT=" :
"FMT="),
CONS(EXPRESSION, $1, NULL));
}
else {
ParserError("Syntax", "The unit identifier and the format identifier"
" must be first and second in the control info list (standard Page F-12)");
}
ici += 1;
}
;
opt_lio_elem:
{ $$ = NULL; }
| lio_elem
{ $$ = MakeIoList($1); }
;
lio_elem: io_elem
{ $$ = CONS(EXPRESSION, $1, NULL); }
| lio_elem TK_COMMA io_elem
{ $$ = CONS(EXPRESSION, $3, $1); }
;
io_elem: expression
{ $$ = $1; }
;
pause_inst: TK_PAUSE opt_expression
{ $$ = MakeZeroOrOneArgCallInst("PAUSE", $2); }
;
stop_inst: TK_STOP opt_expression
{ $$ = MakeZeroOrOneArgCallInst("STOP", $2); }
;
continue_inst: TK_CONTINUE
{ $$ = MakeZeroOrOneArgCallInst("CONTINUE", expression_undefined);}
;
do_inst: TK_DO label opt_virgule atom do_plage
{
MakeDoInst($4, $5, $2);
$$ = instruction_undefined;
}
;
bdo_inst: TK_DO atom do_plage
{
MakeDoInst($2, $3, "BLOCKDO");
$$ = instruction_undefined;
}
;
wdo_inst: TK_DO TK_WHILE TK_LPAR expression TK_RPAR
{
if(expression_implied_do_p($4))
ParserError("Syntax", "Unexpected implied DO\n");
MakeWhileDoInst($4, "BLOCKDO");
$$ = instruction_undefined;
}
| TK_DO label TK_WHILE TK_LPAR expression TK_RPAR
{
if(expression_implied_do_p($5))
ParserError("Syntax", "Unexpected implied DO\n");
MakeWhileDoInst($5, $2);
$$ = instruction_undefined;
}
;
do_plage: TK_EQUALS expression TK_COMMA expression
{
if(expression_implied_do_p($2) || expression_implied_do_p($4))
ParserError("Syntax", "Unexpected implied DO\n");
$$ = make_range($2, $4, int_to_expression(1));
}
| TK_EQUALS expression TK_COMMA expression TK_COMMA expression
{
if(expression_implied_do_p($2) || expression_implied_do_p($4)
|| expression_implied_do_p($6))
ParserError("Syntax", "Unexpected implied DO\n");
$$ = make_range($2, $4, $6);
}
;
endif_inst: TK_ENDIF
{ MakeEndifInst(); }
;
enddo_inst: TK_ENDDO
{ MakeEnddoInst(); }
;
else_inst: TK_ELSE
{ MakeElseInst(true); }
;
elseif_inst: TK_ELSEIF TK_LPAR expression TK_RPAR TK_THEN
{
int elsifs = MakeElseInst(false);
if(expression_implied_do_p($3))
ParserError("Syntax", "Unexpected implied DO\n");
MakeBlockIfInst( $3, elsifs+1 );
$$ = instruction_undefined;
}
;
blockif_inst: TK_IF TK_LPAR expression TK_RPAR TK_THEN
{
if(expression_implied_do_p($3))
ParserError("Syntax", "Unexpected implied DO\n");
MakeBlockIfInst($3,0);
$$ = instruction_undefined;
}
;
logicalif_inst: TK_IF TK_LPAR expression TK_RPAR inst_exec
{
if(expression_implied_do_p($3))
ParserError("Syntax", "Unexpected implied DO\n");
$$ = MakeLogicalIfInst($3, $5);
}
;
arithmif_inst: TK_IF TK_LPAR expression TK_RPAR
label TK_COMMA label TK_COMMA label
{
if(expression_implied_do_p($3))
ParserError("Syntax", "Unexpected implied DO\n");
$$ = MakeArithmIfInst($3, $5, $7, $9);
}
;
goto_inst: TK_GOTO label
{
$$ = MakeGotoInst($2);
}
| TK_GOTO TK_LPAR licon TK_RPAR opt_virgule expression
{
if(expression_implied_do_p($6))
ParserError("Syntax", "Unexpected implied DO\n");
$$ = MakeComputedGotoInst($3, $6);
}
| TK_GOTO entity_name opt_virgule TK_LPAR licon TK_RPAR
{
if(get_bool_property("PARSER_SUBSTITUTE_ASSIGNED_GOTO")) {
$$ = MakeAssignedGotoInst($5, $2);
}
else {
ParserError("parser", "assigned goto statement prohibited"
" unless property PARSER_SUBSTITUTE_ASSIGNED_GOTO is set\n");
}
}
| TK_GOTO entity_name
{
if(get_bool_property("PARSER_SUBSTITUTE_ASSIGNED_GOTO")) {
ParserError("parser", "assigned goto statement cannot be"
" desugared without a target list\n");
}
else {
ParserError("parser", "assigned goto statement prohibited\n");
}
}
;
licon: label
{
$$ = CONS(STRING, $1, NIL);
}
| licon TK_COMMA label
{
$$ = CONS(STRING, $3, $1);
}
;
assignment_inst: TK_ASSIGN icon TK_TO atom
{
if(get_bool_property("PARSER_SUBSTITUTE_ASSIGNED_GOTO")) {
expression e = entity_to_expression($2);
$$ = MakeAssignInst($4, e);
}
else {
ParserError("parser", "ASSIGN statement prohibited by PIPS"
" unless property PARSER_SUBSTITUTE_ASSIGNED_GOTO is set\n");
}
}
| atom TK_EQUALS expression
{
syntax s = $1;
syntax new_s = syntax_undefined;
if(expression_implied_do_p($3))
ParserError("Syntax", "Unexpected implied DO\n");
new_s = CheckLeftHandSide(s);
$$ = MakeAssignInst(new_s, $3);
}
;
format_inst: TK_FORMAT
{
set_first_format_statement();
$$ = MakeZeroOrOneArgCallInst("FORMAT",
MakeCharacterConstantExpression(FormatValue));
}
;
save_inst: TK_SAVE
{ save_all_entities(); }
| TK_SAVE lsavename
| TK_STATIC lsavename
;
lsavename: savename
| lsavename TK_COMMA savename
;
savename: entity_name
{ ProcessSave($1); }
| common_name
{ SaveCommon($1); }
;
intrinsic_inst: TK_INTRINSIC global_entity_name
{
(void) DeclareIntrinsic($2);
}
| intrinsic_inst TK_COMMA global_entity_name
{
(void) DeclareIntrinsic($3);
}
;
external_inst: TK_EXTERNAL functional_entity_name
{
CurrentType = type_undefined;
(void) DeclareExternalFunction($2);
}
| external_inst TK_COMMA functional_entity_name
{
(void) DeclareExternalFunction($3);
}
;
type_inst: fortran_type declaration
{}
| type_inst TK_COMMA declaration
;
declaration: entity_name decl_tableau lg_fortran_type
{
/* the size returned by lg_fortran_type should be
consistent with CurrentType unless it is of type string
or undefined */
type t = CurrentType;
if(t != type_undefined) {
basic b;
if(!type_variable_p(CurrentType))
FatalError("yyparse", "ill. type for CurrentType\n");
b = variable_basic(type_variable(CurrentType));
/* character [*len1] foo [*len2]:
* if len2 is "default" then len1
*/
if(basic_string_p(b))
t = value_intrinsic_p($3)? /* ??? default */
copy_type(t):
MakeTypeVariable
(make_basic(is_basic_string, $3), NIL);
DeclareVariable($1, t, $2,
storage_undefined, value_undefined);
if(basic_string_p(b))
free_type(t);
}
else
DeclareVariable($1, t, $2,
storage_undefined, value_undefined);
$$ = $1;
}
;
decl_tableau:
{
$$ = NULL;
}
| TK_LPAR ldim_tableau TK_RPAR
{
$$ = $2;
}
;
ldim_tableau: dim_tableau
{
$$ = CONS(DIMENSION, $1, NULL);
}
| dim_tableau TK_COMMA ldim_tableau
{
$$ = CONS(DIMENSION, $1, $3);
}
;
dim_tableau: expression
{
expression e = $1;
type t = expression_to_type(e);
if(scalar_integer_type_p(t))
$$ = make_dimension(int_to_expression(1), e, NIL);
else // Not OK with gfortran, maybe OK with f77
ParserError("Syntax",
"Array sized with a non-integer expression");
free_type(t);
}
| TK_STAR
{
$$ = make_dimension(int_to_expression(1),
MakeNullaryCall(CreateIntrinsic(UNBOUNDED_DIMENSION_NAME)),
NIL);
}
| expression TK_COLON TK_STAR
{
$$ = make_dimension($1,
MakeNullaryCall(CreateIntrinsic(UNBOUNDED_DIMENSION_NAME)),
NIL);
}
| expression TK_COLON expression
{
expression e1 = $1;
type t1 = expression_to_type(e1);
expression e2 = $3;
type t2 = expression_to_type(e2);
if(scalar_integer_type_p(t1) && scalar_integer_type_p(t2))
$$ = make_dimension(e1, e2, NIL);
else // Not OK with gfortran, maybe OK with f77
ParserError("Syntax",
"Array sized with a non-integer expression");
free_type(t1), free_type(t2);
}
;
common_inst: common declaration
{
$$ = NameToCommon(BLANK_COMMON_LOCAL_NAME);
AddVariableToCommon($$, $2);
}
| common common_name declaration
{
$$ = $2;
AddVariableToCommon($$, $3);
}
| common_inst TK_COMMA declaration
{
$$ = $1;
AddVariableToCommon($$, $3);
}
| common_inst opt_virgule common_name declaration
{
$$ = $3;
AddVariableToCommon($$, $4);
}
;
common: TK_COMMON
{
CurrentType = type_undefined;
}
;
common_name: TK_CONCAT
{
$$ = NameToCommon(BLANK_COMMON_LOCAL_NAME);
}
| TK_SLASH global_name TK_SLASH
{
$$ = NameToCommon($2);
}
;
pointer_inst: TK_POINTER TK_LPAR entity_name TK_COMMA entity_name decl_tableau TK_RPAR
{
DeclarePointer($3, $5, $6);
}
;
equivalence_inst: TK_EQUIVALENCE lequivchain
;
lequivchain: equivchain
| lequivchain TK_COMMA equivchain
;
equivchain: TK_LPAR latom TK_RPAR
{ StoreEquivChain($2); }
;
latom: atom
{
$$ = make_chain(CONS(ATOM, MakeEquivAtom($1), (cons*) NULL));
}
| latom TK_COMMA atom
{
chain_atoms($1) = CONS(ATOM, MakeEquivAtom($3),
chain_atoms($1));
$$ = $1;
}
;
dimension_inst: dimension declaration
{
}
| dimension_inst TK_COMMA declaration
{
}
;
dimension: TK_DIMENSION
{
CurrentType = type_undefined;
}
;
data_inst: TK_DATA ldatavar TK_SLASH ldataval TK_SLASH
{
/* AnalyzeData($2, $4); */
MakeDataStatement($2, $4);
}
| data_inst opt_virgule ldatavar TK_SLASH ldataval TK_SLASH
{
/* AnalyzeData($3, $5); */
MakeDataStatement($3, $5);
}
;
ldatavar: datavar
{
$$ = CONS(EXPRESSION, $1, NIL);
}
| ldatavar TK_COMMA datavar
{
$$ = gen_nconc($1, CONS(EXPRESSION, $3, NIL));
}
;
/* rule reversal because of a stack overflow; bug hit.f */
ldataval: dataval
{
$$ = CONS(EXPRESSION, $1, NIL);
}
| ldataval TK_COMMA dataval
{
$$ = gen_nconc($1, CONS(EXPRESSION, $3, NIL));
}
;
dataval: dataconst
{
$$ = MakeDataValueSet(expression_undefined, $1);
}
| dataconst TK_STAR dataconst
{
$$ = MakeDataValueSet($1, $3);
}
;
dataconst: const_simple /* expression -> shift/reduce conflicts */
{
$$ = $1;
}
| TK_LPAR const_simple TK_COMMA const_simple TK_RPAR
{
$$ = MakeComplexConstantExpression($2, $4);
}
| entity_name
{
/* Cachan bug 4: there should be a check about the entity
* returned as $1 because MakeDatVal() is going to try
* to evaluate that expression. The entity must be a
* parameter.
*/
if(symbolic_constant_entity_p($1)) {
$$ = make_expression(make_syntax(is_syntax_call,
make_call($1, NIL)),
normalized_undefined);
}
else {
user_warning("gram", "Symbolic constant expected: %s\n",
entity_local_name($1));
if(strcmp("Z", entity_local_name($1))==0) {
user_warning("gram",
"Might be a non supported hexadecimal constant\n");
}
ParserError("gram", "Error in initializer");
}
}
/*
| entity_name TK_LPAR const_simple TK_COMMA const_simple TK_RPAR
{
bool simple = ENTITY_IMPLIED_CMPLX_P($1);
pips_assert("is implied complex",
simple || ENTITY_IMPLIED_DCMPLX_P($1) );
$$ = MakeBinaryCall(CreateIntrinsic
(simple? IMPLIED_COMPLEX_NAME: IMPLIED_DCOMPLEX_NAME), $3, $5);
}
*/
;
datavar: atom
{
$$ = make_expression($1, normalized_undefined);
}
| dataidl
{ $$ = $1; }
;
dataidl: TK_LPAR ldatavar TK_COMMA entity_name do_plage TK_RPAR
{
/* $$ = MakeDataVar($2, $5); */
reference r = make_reference($4, NIL);
syntax s = make_syntax(is_syntax_reference, r);
$$ = MakeImpliedDo(s, $5, $2);
}
;
implicit_inst: TK_IMPLICIT limplicit
{
/* Formal parameters have inherited default implicit types */
retype_formal_parameters();
}
;
limplicit: implicit
{
}
| limplicit TK_COMMA implicit
{
}
;
implicit: fortran_type TK_LPAR l_letter_letter TK_RPAR
{
}
;
l_letter_letter: letter_letter
{
}
| l_letter_letter TK_COMMA letter_letter
{
}
;
letter_letter: letter
{
basic b;
pips_assert("gram.y", type_variable_p(CurrentType));
b = variable_basic(type_variable(CurrentType));
cr_implicit(basic_tag(b), SizeOfElements(b), $1, $1);
}
| letter TK_MINUS letter
{
basic b;
pips_assert("gram.y", type_variable_p(CurrentType));
b = variable_basic(type_variable(CurrentType));
cr_implicit(basic_tag(b), SizeOfElements(b), $1, $3);
}
;
letter: TK_NAME
{
$$ = $1[0]; free($1);
}
;
parameter_inst: TK_PARAMETER TK_LPAR lparametre TK_RPAR
;
lparametre: parametre
| lparametre TK_COMMA parametre
;
parametre: entity_name TK_EQUALS expression
{
AddEntityToDeclarations(MakeParameter($1, $3), get_current_module_entity());
}
;
entity_name: name
{
/* malloc_verify(); */
/* if SafeFind were always used, intrinsic would mask local
variables, either when the module declarations are not
available or when a new entity still has to be
declared. See Validation/capture01.f */
/* Let's try not to search intrinsics in SafeFindOrCreateEntity(). */
/* Do not declare undeclared variables, because it generates
a problem when processing entries. */
/* $$ = SafeFindOrCreateEntity(CurrentPackage, $1); */
if(!entity_undefined_p(get_current_module_entity())) {
$$ = SafeFindOrCreateEntity(CurrentPackage, $1);
/* AddEntityToDeclarations($$, get_current_module_entity()); */
}
else
$$ = FindOrCreateEntity(CurrentPackage, $1);
free($1);
}
;
name: TK_NAME
{ $$ = $1; }
;
module_name: global_name
{
/* $$ = FindOrCreateEntity(CurrentPackage, $1); */
/* $$ = FindOrCreateEntity(TOP_LEVEL_MODULE_NAME, $1); */
CurrentPackage = strdup($1);
BeginingOfProcedure();
free($1);
$$ = (char*)CurrentPackage;
}
;
global_entity_name: global_name
{
/* $$ = FindOrCreateEntity(CurrentPackage, $1); */
$$ = FindOrCreateEntity(TOP_LEVEL_MODULE_NAME, $1);
free($1);
}
;
functional_entity_name: name
{
/* This includes BLOCKDATA modules because of EXTERNAL */
$$ = NameToFunctionalEntity($1);
free($1);
}
;
global_name: TK_NAME
{ $$ = $1; }
;
opt_lformalparameter:
{
$$ = NULL;
}
| TK_LPAR TK_RPAR
{
$$ = NULL;
}
| TK_LPAR lformalparameter TK_RPAR
{
/* Too early: the current module is still unknown */
/* $$ = add_formal_return_code($2); */
$$ = $2;
}
;
lformalparameter: entity_name
{
$$ = CONS(ENTITY, $1, NULL);
}
| TK_STAR
{
uses_alternate_return(true);
$$ = CONS(ENTITY,
generate_pseudo_formal_variable_for_formal_label
(CurrentPackage, get_current_number_of_alternate_returns()),
NIL);
}
| lformalparameter TK_COMMA entity_name
{
$$ = gen_nconc($1, CONS(ENTITY, $3, NIL));
}
| lformalparameter TK_COMMA TK_STAR
{
uses_alternate_return(true);
$$ = gen_nconc($1, CONS(ENTITY,
generate_pseudo_formal_variable_for_formal_label
(CurrentPackage, get_current_number_of_alternate_returns()),
NIL));
}
;
opt_fortran_type: fortran_type
{
$$ = CurrentType = $1 ;
}
|
{
$$ = CurrentType = type_undefined;
}
;
fortran_type: fortran_basic_type lg_fortran_type
{
if (value_intrinsic_p($2)) /* ??? default! */
{
free_value($2);
$2 = make_value_constant(
make_constant_int( CurrentTypeSize));
}
$$ = CurrentType = MakeFortranType($1, $2);
}
;
fortran_basic_type: TK_INTEGER
{
$$ = is_basic_int;
CurrentTypeSize = DEFAULT_INTEGER_TYPE_SIZE;
}
| TK_REAL
{
$$ = is_basic_float;
CurrentTypeSize = DEFAULT_REAL_TYPE_SIZE;
}
| TK_DOUBLEPRECISION
{
$$ = is_basic_float;
CurrentTypeSize = DEFAULT_DOUBLEPRECISION_TYPE_SIZE;
}
| TK_LOGICAL
{
$$ = is_basic_logical;
CurrentTypeSize = DEFAULT_LOGICAL_TYPE_SIZE;
}
| TK_COMPLEX
{
$$ = is_basic_complex;
CurrentTypeSize = DEFAULT_COMPLEX_TYPE_SIZE;
}
| TK_DOUBLECOMPLEX
{
$$ = is_basic_complex;
CurrentTypeSize = DEFAULT_DOUBLECOMPLEX_TYPE_SIZE;
}
| TK_CHARACTER
{
$$ = is_basic_string;
CurrentTypeSize = DEFAULT_CHARACTER_TYPE_SIZE;
}
;
lg_fortran_type:
{
$$ = make_value(is_value_intrinsic, UU); /* ??? default! */
/* was: $$ = make_value(is_value_constant,
* make_constant(is_constant_int, CurrentTypeSize));
* then how to differentiate character*len1 foo[*len2]
* if len2 is 1 or whatever... the issue is that
* there should be two lg_..., one for the default that
* would change CurrentTypeSize at ival, and the other not...
* FC, 13/06/96
*/
}
| TK_STAR TK_LPAR TK_STAR TK_RPAR /* CHARACTER *(*) */
{
$$ = make_value_unknown();
}
| TK_STAR TK_LPAR expression TK_RPAR
{
$$ = MakeValueSymbolic($3);
}
| TK_STAR ival
{
$$ = make_value_constant(make_constant_int($2));
}
;
atom: entity_name
{
$$ = MakeAtom($1, NIL, expression_undefined,
expression_undefined, false);
}
| entity_name indices
{
$$ = MakeAtom($1, $2, expression_undefined,
expression_undefined, true);
}
| entity_name TK_LPAR opt_expression TK_COLON opt_expression TK_RPAR
{
$$ = MakeAtom($1, NIL, $3, $5, true);
}
| entity_name indices TK_LPAR opt_expression TK_COLON opt_expression TK_RPAR
{
$$ = MakeAtom($1, $2, $4, $6, true);
}
;
indices: TK_LPAR TK_RPAR
{ $$ = NULL; }
| TK_LPAR lexpression TK_RPAR
{ $$ = FortranExpressionList($2); }
;
lexpression: expression
{
$$ = CONS(EXPRESSION, $1, NULL);
}
| lexpression TK_COMMA expression
{
$$ = gen_nconc($1, CONS(EXPRESSION, $3, NIL));
}
;
opt_expression: expression
{
if(expression_implied_do_p($1))
ParserError("Syntax", "Unexpected implied DO\n");
$$ = $1;
}
|
{ $$ = expression_undefined; }
;
expression: sous_expression
{ $$ = $1; }
| TK_LPAR expression TK_RPAR
{ $$ = $2; }
| TK_LPAR expression TK_COMMA expression TK_RPAR
{
expression c = MakeComplexConstantExpression($2, $4);
if(expression_undefined_p(c))
ParserError("Syntax", "Illegal complex constant\n");
$$ = c;
}
| TK_LPAR expression TK_COMMA atom do_plage TK_RPAR
{ $$ = MakeImpliedDo($4, $5, CONS(EXPRESSION, $2, NIL)); }
| TK_LPAR expression TK_COMMA lexpression TK_COMMA atom do_plage TK_RPAR
{ $$ = MakeImpliedDo($6, $7, CONS(EXPRESSION, $2, $4)); }
;
sous_expression: atom
{
$$ = make_expression($1, normalized_undefined);
}
| unsigned_const_simple
{
$$ = MakeNullaryCall($1);
}
| signe expression %prec TK_STAR
{
if ($1 == -1)
$$ = MakeFortranUnaryCall(CreateIntrinsic("--"), $2);
else
$$ = $2;
}
| expression TK_PLUS expression
{
$$ = MakeFortranBinaryCall(CreateIntrinsic("+"), $1, $3);
}
| expression TK_MINUS expression
{
$$ = MakeFortranBinaryCall(CreateIntrinsic("-"), $1, $3);
}
| expression TK_STAR expression
{
$$ = MakeFortranBinaryCall(CreateIntrinsic("*"), $1, $3);
}
| expression TK_SLASH expression
{
$$ = MakeFortranBinaryCall(CreateIntrinsic("/"), $1, $3);
}
| expression TK_POWER expression
{
$$ = MakeFortranBinaryCall(CreateIntrinsic("**"),
$1, $3);
}
| expression oper_rela expression %prec TK_EQ
{
$$ = MakeFortranBinaryCall($2, $1, $3);
}
| expression TK_EQV expression
{
$$ = MakeFortranBinaryCall(CreateIntrinsic(".EQV."),
$1, $3);
}
| expression TK_NEQV expression
{
$$ = MakeFortranBinaryCall(CreateIntrinsic(".NEQV."),
$1, $3);
}
| expression TK_OR expression
{
$$ = MakeFortranBinaryCall(CreateIntrinsic(".OR."),
fix_if_condition($1),
fix_if_condition($3));
}
| expression TK_AND expression
{
$$ = MakeFortranBinaryCall(CreateIntrinsic(".AND."),
fix_if_condition($1),
fix_if_condition($3));
}
| TK_NOT expression
{
$$ = MakeFortranUnaryCall(CreateIntrinsic(".NOT."),
fix_if_condition($2));
}
| expression TK_CONCAT expression
{
$$ = MakeFortranBinaryCall(CreateIntrinsic("//"),
$1, $3);
}
;
io_expr: unpar_io_expr
| TK_LPAR io_expr TK_RPAR
{ $$ = $2; }
;
unpar_io_expr: atom
{
$$ = make_expression($1, normalized_undefined);
}
/* | const_simple */
| unsigned_const_simple
{
$$ = MakeNullaryCall($1);
}
| signe io_expr %prec TK_STAR
{
if ($1 == -1)
$$ = MakeFortranUnaryCall(CreateIntrinsic("--"), $2);
else
$$ = $2;
}
| io_expr TK_PLUS io_expr
{
$$ = MakeFortranBinaryCall(CreateIntrinsic("+"), $1, $3);
}
| io_expr TK_MINUS io_expr
{
$$ = MakeFortranBinaryCall(CreateIntrinsic("-"), $1, $3);
}
| io_expr TK_STAR io_expr
{
$$ = MakeFortranBinaryCall(CreateIntrinsic("*"), $1, $3);
}
| io_expr TK_SLASH io_expr
{
$$ = MakeFortranBinaryCall(CreateIntrinsic("/"), $1, $3);
}
| io_expr TK_POWER io_expr
{
$$ = MakeFortranBinaryCall(CreateIntrinsic("**"),
$1, $3);
}
| io_expr TK_CONCAT io_expr
{
$$ = MakeFortranBinaryCall(CreateIntrinsic("//"),
$1, $3);
}
;
const_simple: opt_signe unsigned_const_simple
{
if ($1 == -1)
$$ = MakeUnaryCall(CreateIntrinsic("--"),
MakeNullaryCall($2));
else
$$ = MakeNullaryCall($2);
}
;
unsigned_const_simple: TK_TRUE
{
$$ = SafeMakeConstant(".TRUE.", is_basic_logical, ParserError);
}
| TK_FALSE
{
$$ = SafeMakeConstant(".FALSE.", is_basic_logical, ParserError);
}
| icon
{
$$ = $1;
}
| TK_DCON
{
$$ = make_Fortran_constant_entity($1, is_basic_float,
DEFAULT_DOUBLEPRECISION_TYPE_SIZE);
free($1);
}
| TK_SCON
{
$$ = SafeMakeConstant($1, is_basic_string, ParserError);
free($1);
}
| TK_RCON
{
$$ = SafeMakeConstant($1, is_basic_float, ParserError);
free($1);
}
;
icon: TK_ICON
{
$$ = SafeMakeConstant($1, is_basic_int, ParserError);
free($1);
}
;
label: TK_ICON
{
$$ = $1;
}
;
ival: TK_ICON
{
$$ = atoi($1);
free($1);
}
;
opt_signe:
{
$$ = 1;
}
| signe
{
$$ = $1;
}
;
signe: TK_PLUS
{
$$ = 1;
}
| TK_MINUS
{
$$ = -1;
}
;
oper_rela: TK_EQ
{
$$ = CreateIntrinsic(".EQ.");
}
| TK_NE
{
$$ = CreateIntrinsic(".NE.");
}
| TK_LT
{
$$ = CreateIntrinsic(".LT.");
}
| TK_LE
{
$$ = CreateIntrinsic(".LE.");
}
| TK_GE
{
$$ = CreateIntrinsic(".GE.");
}
| TK_GT
{
$$ = CreateIntrinsic(".GT.");
}
;
io_keyword: TK_PRINT
{ $$ = TK_PRINT; ici = 1; }
| TK_WRITE
{ $$ = TK_WRITE; ici = 1; }
| TK_READ
{ $$ = TK_READ; ici = 1; }
| TK_CLOSE
{ $$ = TK_CLOSE; ici = 1; }
| TK_OPEN
{ $$ = TK_OPEN; ici = 1; }
| TK_ENDFILE
{ $$ = TK_ENDFILE; ici = 1; }
| TK_BACKSPACE
{ $$ = TK_BACKSPACE; ici = 1; }
| TK_REWIND
{ $$ = TK_REWIND; ici = 1; }
| TK_INQUIRE
{ $$ = TK_INQUIRE; ici = 1; }
;
iobuf_keyword: TK_BUFFERIN
{ $$ = TK_BUFFERIN; ici = 1; }
| TK_BUFFEROUT
{ $$ = TK_BUFFEROUT ; ici = 1; }
;
psf_keyword: TK_PROGRAM
{ $$ = TK_PROGRAM; init_ghost_variable_entities(); }
| TK_SUBROUTINE
{ $$ = TK_SUBROUTINE; init_ghost_variable_entities();
set_current_number_of_alternate_returns();}
| TK_FUNCTION
{ $$ = TK_FUNCTION; init_ghost_variable_entities();
set_current_number_of_alternate_returns();}
| TK_BLOCKDATA
{ $$ = TK_BLOCKDATA; init_ghost_variable_entities(); }
;
opt_virgule:
| TK_COMMA
;
%%