home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
OS/2 Shareware BBS: 10 Tools
/
10-Tools.zip
/
FTNCHEK2.ZIP
/
SOURCE
/
FORTRAN.Y
< prev
next >
Wrap
Text File
|
1993-02-01
|
56KB
|
2,646 lines
/*
fortran.y:
Yacc grammar for Fortran program checker. Uses the yylex()
in file FORLEX.C
*/
%{
/*
fortran.c:
Copyright (C) 1992 by Robert K. Moniot.
This program is free software. Permission is granted to
modify it and/or redistribute it. There is no warranty
for this program.
This grammar is ANSI standard-conforming, except for:
-- Sensitive to whitespace, which is used in lexical analysis
to separate keywords and identifiers from context. This
is a design feature. Rules are the same as for Pascal.
(Of course stmt fields and end-of-line still honored.)
Note: a complex constant cannot be split across lines.
-- Currently, some keywords are partially reserved: may
only be used for scalar variables. (See keywords.c) This
is the fault of the lexical analyzer (too little lookahead).
Extensions supported:
-- Case insensitive.
-- Hollerith constants.
-- Variable names may be longer than 6 characters. Also
allows underscores in names.
-- DO ... ENDDO and DO WHILE loop forms allowed.
-- NAMELIST supported.
-- TYPE and ACCEPT I/O statements allowed.
-- Tabs are permitted in input, and (except in character data)
expand into blanks up to the next column equal to 1 mod 8.
-- Type declarations INTEGER*2, REAL*8, etc. are allowed.
REAL*8 becomes DOUBLE PRECISION. For others, length spec
is ignored.
-- IMPLICIT NONE allowed.
*/
/* Author: R. Moniot
* Date: August 1988
* Last revision: January 1992
*/
#include <stdio.h>
#include <string.h>
#include "ftnchek.h"
#include "symtab.h"
void exit();
int current_datatype, /* set when parse type_name or type_stmt */
stmt_sequence_no, /* set when parsing, reset to 0 at end_stmt */
control_item_count; /* count of items in control_info_list */
extern unsigned prev_stmt_line_num; /* shared with advance */
int current_module_hash = -1, /* hashtable index of current module name */
current_module_type,
executable_stmt=FALSE,
prev_stmt_class=0,
/* flags for lexer */
complex_const_allowed=FALSE, /* for help in lookahead for these */
inside_format=FALSE, /* when inside parens of FORMAT */
integer_context=FALSE, /* says integers-only are to follow */
prev_goto=FALSE,
goto_flag=FALSE; /* if unconditional GOTO was encountered */
long exec_stmt_count=0; /* count of executable stmts in program */
PRIVATE void
print_comlist(), print_exprlist(), END_processing();
PRIVATE Token *
append_token();
PRIVATE int
do_bounds_type();
/* Uses of Token fields for nonterminals: */
/*
1. dim_bound_lists: dimensioning info for arrays:
token.class = no. of dimensions,
token.subclass = no. of elements
2. expressions
token.value.integer = hash index (of identifier)
token.class = type_byte = storage_class << 4 + datatype
token.subclass = flags: CONST_EXPR, LVALUE_EXPR, etc.
3. common variable lists
token.subclass = flag: COMMA_FLAG used to handle extra/missing commas
*/
#define seq_header 1
#define seq_implicit 2
#define seq_specif 3
#define seq_stmt_fun 4
#define seq_exec 5
#define seq_end 6
#define DBG(S) if(debug_parser) fprintf(list_fd,"\nproduction: S");
#define DBGstr(S,str) \
if(debug_parser) fprintf(list_fd,"\nproduction: S%s",str);
%}
%token tok_identifier
%token tok_array_identifier
%token tok_label
%token tok_integer_const
%token tok_real_const
%token tok_dp_const
%token tok_complex_const
%token tok_logical_const
%token tok_string
%token tok_hollerith
%token tok_edit_descriptor
%token tok_letter
%token tok_relop /* .EQ. .NE. .LT. .LE. .GT. .GE. */
%token tok_AND
%token tok_OR
%token tok_EQV
%token tok_NEQV
%token tok_NOT
%token tok_power /* ** */
%token tok_concat /* // */
%token tok_ASSIGN
%token tok_ACCEPT
%token tok_BACKSPACE
%token tok_BLOCK
%token tok_BLOCKDATA
%token tok_CALL
%token tok_CHARACTER
%token tok_CLOSE
%token tok_COMMON
%token tok_COMPLEX
%token tok_CONTINUE
%token tok_BYTE
%token tok_DATA
%token tok_DIMENSION
%token tok_DO
%token tok_DOUBLE
%token tok_DOUBLEPRECISION
%token tok_DOWHILE
%token tok_ELSE
%token tok_ELSEIF
%token tok_END
%token tok_ENDDO
%token tok_ENDFILE
%token tok_ENDIF
%token tok_ENTRY
%token tok_EQUIVALENCE
%token tok_EXTERNAL
%token tok_FILE
%token tok_FORMAT
%token tok_FUNCTION
%token tok_GO
%token tok_GOTO
%token tok_IF
%token tok_IMPLICIT
%token tok_INCLUDE
%token tok_INQUIRE
%token tok_INTEGER
%token tok_INTRINSIC
%token tok_LOGICAL
%token tok_NAMELIST
%token tok_OPEN
%token tok_PARAMETER
%token tok_PAUSE
%token tok_PRECISION
%token tok_PRINT
%token tok_PROGRAM
%token tok_READ
%token tok_REAL
%token tok_RETURN
%token tok_REWIND
%token tok_SAVE
%token tok_STOP
%token tok_SUBROUTINE
%token tok_TO
%token tok_TYPE
%token tok_THEN
%token tok_WHILE
%token tok_WRITE
%token tok_illegal /* Illegal token unused in grammar: induces syntax error */
%token EOS 127 /* Character for end of statement. */
%nonassoc tok_relop
%left REDUCE ')' /* Used at unit_io to force a reduction */
%%
/* The following grammar is based on the ANSI manual, diagrams
* of section F. Numbers in the comments refer to the diagram
* corresponding to the grammar rule.
*/
/* 1-5 */
prog_body : stmt_list
| /* empty file */
;
stmt_list : stmt_list_item
| stmt_list stmt_list_item
;
stmt_list_item : stmt
{
/* Create id token for prog if unnamed. */
if(current_module_hash == -1) {
implied_id_token(&($1),unnamed_prog);
def_function(
type_PROGRAM,&($1),(Token*)NULL);
current_module_hash =
def_curr_module(&($1));
current_module_type = type_PROGRAM;
}
prev_stmt_class = curr_stmt_class;
integer_context = FALSE;
}
| end_stmt
{
if(current_module_hash == -1) {
implied_id_token(&($1),unnamed_prog);
def_function(
type_PROGRAM,&($1),(Token*)NULL);
current_module_hash =
def_curr_module(&($1));
current_module_type = type_PROGRAM;
}
if(prev_stmt_class != tok_RETURN)
do_RETURN(current_module_hash,&($1));
END_processing(&($$));
goto_flag = prev_goto = FALSE;
prev_stmt_class = curr_stmt_class;
}
| include_stmt
| EOS /* "sticky" EOF for needed delay */
;
/* Statements: note that ordering by category
of statement is not enforced in the grammar
but is deferred to semantic processing.
*/
stmt : tok_label unlabeled_stmt
{
#ifdef CHECK_LABELS
def_label(&($1));
#endif
if(executable_stmt)
prev_goto = goto_flag;
}
| unlabeled_stmt
{
if(executable_stmt) {
if(prev_goto)
syntax_error($1.line_num, NO_COL_NUM,
"No path to this statement");
prev_goto = goto_flag;
}
}
;
unlabeled_stmt : subprogram_header
{
exec_stmt_count = 0;
executable_stmt = FALSE;
}
| specification_stmt
{
executable_stmt = FALSE;
}
| executable_stmt
{ /* handle statement functions correctly */
if(is_true(STMT_FUNCTION_EXPR, $1.subclass)
&& stmt_sequence_no <= seq_stmt_fun) {
stmt_sequence_no = seq_stmt_fun;
executable_stmt = FALSE;
}
else {
stmt_sequence_no = seq_exec;
++exec_stmt_count;
executable_stmt = TRUE;
}
}
| restricted_stmt
{
stmt_sequence_no = seq_exec;
++exec_stmt_count;
executable_stmt = TRUE;
}
| error EOS
{
executable_stmt = TRUE;
if(stmt_sequence_no == 0)
stmt_sequence_no = seq_header;
complex_const_allowed = FALSE; /* turn off flags */
inside_format=FALSE;
integer_context = FALSE;
$$.line_num = prev_stmt_line_num; /* best guess */
yyerrok; /* (error message already given) */
}
;
subprogram_header: prog_stmt
{
current_module_type = type_PROGRAM;
}
| function_stmt
{
current_module_type = type_SUBROUTINE;
}
| subroutine_stmt
{
current_module_type = type_SUBROUTINE;
}
| block_data_stmt
{
current_module_type = type_BLOCK_DATA;
}
;
end_stmt : unlabeled_end_stmt
| tok_label unlabeled_end_stmt
;
unlabeled_end_stmt: tok_END EOS
;
include_stmt : tok_INCLUDE tok_string EOS
{
#ifdef ALLOW_INCLUDE
if(f77_standard) {
nonstandard($1.line_num,$1.col_num);
}
open_include_file($2.value.string);
#else
syntax_error($1.line_num,$1.col_num,
"statement not permitted");
#endif
}
;
/* 5,6 */
/* Note that stmt_function_stmt is not distinguished from
assignment_stmt, but assign (label to variable) is.
Also, format_stmt w/o label is accepted here.
ANSI standard for statement sequencing is enforced here. */
specification_stmt:
entry_stmt
{
if(stmt_sequence_no < seq_implicit) {
stmt_sequence_no = seq_implicit;
}
goto_flag = prev_goto = FALSE;
}
| format_stmt
{
if(stmt_sequence_no < seq_implicit) {
stmt_sequence_no = seq_implicit;
}
}
| parameter_stmt
{
if(stmt_sequence_no > seq_specif) {
syntax_error($1.line_num, NO_COL_NUM,
"Statement out of order.");
}
else {
if(stmt_sequence_no < seq_implicit) {
stmt_sequence_no = seq_implicit;
}
}
}
| implicit_stmt
{
if(stmt_sequence_no > seq_implicit) {
syntax_error($1.line_num, NO_COL_NUM,
"Statement out of order.");
}
else {
stmt_sequence_no = seq_implicit;
}
}
| data_stmt
{
if(stmt_sequence_no < seq_stmt_fun) {
stmt_sequence_no = seq_stmt_fun;
}
}
| dimension_stmt
{
if(stmt_sequence_no > seq_specif) {
syntax_error($1.line_num, NO_COL_NUM,
"Statement out of order.");
}
else {
stmt_sequence_no = seq_specif;
}
}
| equivalence_stmt
{
if(stmt_sequence_no > seq_specif) {
syntax_error($1.line_num, NO_COL_NUM,
"Statement out of order.");
}
else {
stmt_sequence_no = seq_specif;
}
}
| common_stmt
{
if(stmt_sequence_no > seq_specif) {
syntax_error($1.line_num, NO_COL_NUM,
"Statement out of order.");
}
else {
stmt_sequence_no = seq_specif;
}
}
| namelist_stmt
{
if(stmt_sequence_no > seq_specif) {
syntax_error($1.line_num, NO_COL_NUM,
"Statement out of order.");
}
else {
stmt_sequence_no = seq_specif;
}
}
| type_stmt
{
if(stmt_sequence_no > seq_specif) {
syntax_error($1.line_num, NO_COL_NUM,
"Statement out of order.");
}
else {
stmt_sequence_no = seq_specif;
}
}
| external_stmt
{
if(stmt_sequence_no > seq_specif) {
syntax_error($1.line_num, NO_COL_NUM,
"Statement out of order.");
}
else {
stmt_sequence_no = seq_specif;
}
}
| intrinsic_stmt
{
if(stmt_sequence_no > seq_specif) {
syntax_error($1.line_num, NO_COL_NUM,
"Statement out of order.");
}
else {
stmt_sequence_no = seq_specif;
}
}
| save_stmt
{
if(stmt_sequence_no > seq_specif) {
syntax_error($1.line_num, NO_COL_NUM,
"Statement out of order.");
}
else {
stmt_sequence_no = seq_specif;
}
}
;
/* 7 */
executable_stmt: /* Allowed in logical IF */
assignment_stmt
{
goto_flag=FALSE;
}
| assign_stmt
{
goto_flag=FALSE;
}
| unconditional_goto
{
goto_flag=TRUE;
}
| computed_goto
{
goto_flag=FALSE; /* fallthru allowed */
}
| assigned_goto
{
goto_flag=TRUE;
}
| arithmetic_if_stmt
{
goto_flag=TRUE;
}
| continue_stmt
{
goto_flag=FALSE;
}
| stop_stmt
{
goto_flag=TRUE;
}
| pause_stmt
{
goto_flag=FALSE;
}
| read_stmt
{
goto_flag=FALSE;
}
| accept_stmt
{
goto_flag=FALSE;
}
| write_stmt
{
goto_flag=FALSE;
}
| print_stmt
{
goto_flag=FALSE;
}
| type_output_stmt
{
goto_flag=FALSE;
}
| rewind_stmt
{
goto_flag=FALSE;
}
| backspace_stmt
{
goto_flag=FALSE;
}
| endfile_stmt
{
goto_flag=FALSE;
}
| open_stmt
{
goto_flag=FALSE;
}
| close_stmt
{
goto_flag=FALSE;
}
| inquire_stmt
{
goto_flag=FALSE;
}
| call_stmt
{
goto_flag=FALSE;
}
| return_stmt
{
goto_flag=TRUE;
}
;
restricted_stmt: /* Disallowed in logical IF */
logical_if_stmt
{
goto_flag=FALSE;
}
| block_if_stmt
{
goto_flag=FALSE;
}
| else_if_stmt
{
prev_goto = goto_flag =FALSE;
}
| else_stmt
{
prev_goto = goto_flag =FALSE;
}
| end_if_stmt
{
prev_goto = goto_flag =FALSE;
}
| do_stmt
{
goto_flag=FALSE;
}
| enddo_stmt
{
goto_flag=FALSE;
}
;
/* 8 */
prog_stmt : tok_PROGRAM {check_seq_header(&($1));}
symbolic_name EOS
{
def_function(
type_PROGRAM,&($3),(Token*)NULL);
current_module_hash =
def_curr_module(&($3));
}
;
/* Note that function & subroutine entry not
* distinguished in this grammar.
*/
/* 9 */
entry_stmt : tok_ENTRY symbolic_name EOS
{
do_ENTRY(&($2),(Token*)NULL
,current_module_hash);
}
| tok_ENTRY symbolic_name '(' dummy_argument_list ')' EOS
{
do_ENTRY(&($2),&($4)
,current_module_hash);
if(debug_parser)
print_exprlist("entry stmt",&($4));
}
;
/* 10 */
function_stmt : unlabeled_function_stmt
;
unlabeled_function_stmt
: typed_function_handle symbolic_name EOS
{
if(f77_standard) {
nonstandard($2.line_num,
$2.col_num+strlen(token_name($2)));
msg_tail(": parentheses required");
}
def_function(
current_datatype,&($2),(Token*)NULL);
current_module_hash=
def_curr_module(&($2));
}
| typed_function_handle symbolic_name
'(' dummy_argument_list ')' EOS
{
def_function(
current_datatype,&($2),&($4));
current_module_hash=
def_curr_module(&($2));
if(debug_parser)
print_exprlist("function stmt",&($4));
}
| plain_function_handle symbolic_name EOS
{
if(f77_standard) {
nonstandard($2.line_num,
$2.col_num+strlen(token_name($2)));
msg_tail(": parentheses required");
}
def_function(
type_UNDECL,&($2),(Token*)NULL);
current_module_hash=
def_curr_module(&($2));
}
| plain_function_handle symbolic_name
'(' dummy_argument_list ')' EOS
{
def_function(
type_UNDECL,&($2),&($4));
current_module_hash=
def_curr_module(&($2));
if(debug_parser)
print_exprlist("function stmt",&($4));
}
;
typed_function_handle
: type_name tok_FUNCTION
{
check_seq_header(&($2));
}
;
plain_function_handle
: tok_FUNCTION
{
check_seq_header(&($1));
}
;
type_name : arith_type_name
| plain_char_type_name
| char_type_name
;
/* 11 not present: see 9 */
/* 12 */
subroutine_stmt : unlabeled_subroutine_stmt
;
unlabeled_subroutine_stmt
: subroutine_handle symbolic_name EOS
{
def_function(
type_SUBROUTINE,&($2),(Token*)NULL);
current_module_hash=
def_curr_module(&($2));
}
| subroutine_handle symbolic_name
'(' dummy_argument_list ')' EOS
{
def_function(
type_SUBROUTINE,&($2),&($4));
current_module_hash=
def_curr_module(&($2));
if(debug_parser)
print_exprlist("subroutine stmt",&($4));
}
;
subroutine_handle: tok_SUBROUTINE
{
check_seq_header(&($1));
}
;
dummy_argument_list: /* empty */
{
$$.next_token = (Token*)NULL;
}
| non_empty_arg_list
;
non_empty_arg_list: dummy_argument
{
$$.next_token = append_token((Token*)NULL,&($1));
}
| non_empty_arg_list ',' dummy_argument
{
$$.next_token = append_token($1.next_token,&($3));
}
;
dummy_argument : symbolic_name
{
def_arg_name(&($1));
primary_id_expr(&($1),&($$));
}
| '*'
{
$$.class = type_byte(class_LABEL,type_LABEL);
$$.subclass = 0;
}
;
/* 13 not present: see 9 */
/* 14 */
block_data_stmt : block_data_handle EOS
{
/* form name %DATnn */
++block_data_number;
sprintf(unnamed_block_data+4,"%02d"
,block_data_number%100);
implied_id_token(&($$),unnamed_block_data);
def_function(
type_BLOCK_DATA,&($$),(Token*)NULL);
current_module_hash=
def_curr_module(&($$));
}
| block_data_handle symbolic_name EOS
{
def_function(
type_BLOCK_DATA,&($2),(Token*)NULL);
current_module_hash=
def_curr_module(&($2));
}
;
block_data_handle: tok_BLOCK tok_DATA
{
check_seq_header(&($2));
}
| tok_BLOCKDATA
{
check_seq_header(&($1));
}
;
/* 15 */
dimension_stmt : tok_DIMENSION array_declarator_list EOS
;
array_declarator_list: array_declarator
| array_declarator_list ',' array_declarator
;
/* 16 */
array_declarator: symbolic_name '(' dim_bound_list ')'
{
def_array_dim(&($1),&($3));
}
;
dim_bound_list : dim_bound_item /* token class = no. of dimensions,
subclass = no. of elements */
{
$$.class = 1;
$$.subclass = $1.subclass;
}
| dim_bound_list ',' dim_bound_item
{
$$.class = $1.class + 1; /* one more dimension */
$$.subclass = $1.subclass * $3.subclass;
}
;
dim_bound_item : dim_bound_expr
{
$$.subclass = $1.value.integer;
}
| dim_bound_expr ':' dim_bound_expr
{ /* avoid getting 0 - 0 + 1 = 1 if bounds nonconstant */
if( datatype_of($1.class) == type_INTEGER
&& is_true(CONST_EXPR,$1.subclass)
&& datatype_of($3.class) == type_INTEGER
&& is_true(CONST_EXPR,$3.subclass) )
$$.subclass = $3.value.integer - $1.value.integer + 1;
else
$$.subclass = 0;
}
| '*'
{
$$.subclass = 0;
}
| dim_bound_expr ':' '*'
{
$$.subclass = 0;
}
;
/* 17 */
equivalence_stmt: tok_EQUIVALENCE {equivalence_flag = TRUE;}
equivalence_list EOS {equivalence_flag = FALSE;}
;
equivalence_list: '(' equivalence_list_item ')'
| equivalence_list ',' '(' equivalence_list_item ')'
;
equivalence_list_item: equiv_entity ',' equiv_entity
{
equivalence(&($1), &($3));
}
| equivalence_list_item ',' equiv_entity
{
equivalence(&($1), &($3));
}
;
/* 17 */
equiv_entity : symbolic_name
{
def_equiv_name(&($1));
}
| array_equiv_name
{
def_equiv_name(&($1));
}
| substring_equiv_name
{
def_equiv_name(&($1));
}
;
array_equiv_name: symbolic_name '(' subscript_list ')'
/* should check */
;
substring_equiv_name: symbolic_name substring_interval
| array_equiv_name substring_interval
;
/* 19 */
common_stmt : tok_COMMON common_variable_list EOS
{
implied_id_token(&($$),blank_com_name);
def_com_block(&($$), &($2));
if(is_true(COMMA_FLAG,$2.subclass))
syntax_error(
$2.line_num,$2.col_num,
"trailing comma");
if(debug_parser)
print_comlist("blank common",&($2));
}
| tok_COMMON common_block_list EOS
{
if(is_true(COMMA_FLAG,$2.subclass))
syntax_error(
$2.line_num,$2.col_num,
"trailing comma");
}
| tok_COMMON common_variable_list common_block_list EOS
{
implied_id_token(&($$),blank_com_name);
def_com_block(&($$),&($2));
if(is_true(COMMA_FLAG,$3.subclass))
syntax_error(
$3.line_num,$3.col_num,
"trailing comma");
if(debug_parser)
print_comlist("blank common",&($2));
}
;
/* The following defns allow trailing commas and missing commas in
order to tolerate the optional comma before /blockname/. The
token subclass holds comma status to allow errors to be caught. */
common_block_list: labeled_common_block
{
$$.subclass = $1.subclass;
}
| common_block_list labeled_common_block
{
$$.subclass = $2.subclass;
$$.line_num = $2.line_num;
$$.col_num = $2.col_num;
}
;
labeled_common_block: common_block_name common_variable_list
{
def_com_block(&($1),&($2));
$$.subclass = $2.subclass;
$$.line_num = $2.line_num;
$$.col_num = $2.col_num;
if(debug_parser)
print_comlist("labeled common",&($2));
}
;
common_block_name: '/' symbolic_name '/'
{
$$ = $2;
}
| '/' '/' /* block with no name */
{
implied_id_token(&($$),blank_com_name);
}
| tok_concat /* "//" becomes this */
{
implied_id_token(&($$),blank_com_name);
}
;
common_variable_list: common_list_item
{
$$.subclass = $1.subclass;
$$.next_token = append_token((Token*)NULL,&($1));
}
| common_variable_list common_list_item
{
if(!is_true(COMMA_FLAG,$1.subclass))
syntax_error(
$2.line_num,$2.col_num-1,
"missing comma");
$$.subclass = $2.subclass;
$$.line_num = $2.line_num;
$$.col_num = $2.col_num;
$$.next_token = append_token($1.next_token,&($2));
}
;
common_list_item: common_entity
{ /* no comma */
$$.subclass = $1.subclass;
make_false(COMMA_FLAG,$$.subclass);
}
| common_entity ','
{ /* has comma */
$$.subclass = $1.subclass;
make_true(COMMA_FLAG,$$.subclass);
}
;
common_entity : symbolic_name
{
def_com_variable(&($1));
primary_id_expr(&($1),&($$));
}
| array_declarator
{
def_com_variable(&($1));
primary_id_expr(&($1),&($$));
}
;
/* NAMELIST : Not Standard
Syntax is:
NAMELIST /group/ var [,var...] [[,] /group/ var [,var...]...]
*/
namelist_stmt : tok_NAMELIST namelist_list EOS
{
if(is_true(COMMA_FLAG,$2.subclass))
syntax_error(
$2.line_num,$2.col_num+strlen(token_name($2)),
"trailing comma");
if(f77_standard) {
nonstandard($1.line_num,$1.col_num);
}
}
;
namelist_list : namelist_decl
| namelist_list namelist_decl
{
$$ = $2;
}
;
namelist_decl : namelist_name namelist_var_list
{
def_namelist(&($1),&($2));
$$ = $2;
}
;
namelist_name : '/' symbolic_name '/'
{
$$ = $2;
}
;
namelist_var_list: namelist_item
{
$$.next_token = append_token((Token*)NULL,&($1));
}
| namelist_var_list namelist_item
{
if(!is_true(COMMA_FLAG,$1.subclass))
syntax_error(
$2.line_num,$2.col_num-1,
"missing comma");
$$.subclass = $2.subclass;
$$.line_num = $2.line_num;
$$.col_num = $2.col_num;
$$.next_token = append_token($1.next_token,&($2));
}
;
namelist_item : symbolic_name
{ /* no comma */
def_namelist_item(&($1));
primary_id_expr(&($1),&($$));
make_false(COMMA_FLAG,$$.subclass);
}
| symbolic_name ','
{ /* has comma */
def_namelist_item(&($1));
primary_id_expr(&($1),&($$));
make_true(COMMA_FLAG,$$.subclass);
}
;
/* 20 */
type_stmt : arith_type_name arith_type_decl_list EOS
| plain_char_type_name char_type_decl_list EOS
| char_type_name char_type_decl_list EOS
| char_type_name ',' char_type_decl_list EOS
;
arith_type_name : sizeable_type_name
/* Allow *len to modify some arith types */
| sizeable_type_name '*' nonzero_unsigned_int_const
{
/* Only REAL*8 is actually recognized */
if(current_datatype == type_REAL
&& $3.value.integer == 8)
current_datatype = type_DP;
if(f77_standard) {
nonstandard($3.line_num,$3.col_num);
}
}
/* Other type disallow *len modifier */
| unsizeable_type_name
;
sizeable_type_name: tok_INTEGER
{
current_datatype = type_INTEGER;
integer_context = TRUE;
}
| tok_REAL
{
current_datatype = type_REAL;
integer_context = TRUE;
}
| tok_COMPLEX
{
current_datatype = type_COMPLEX;
integer_context = TRUE;
}
| tok_LOGICAL
{
current_datatype = type_LOGICAL;
integer_context = TRUE;
}
;
unsizeable_type_name: tok_DOUBLE tok_PRECISION
{
current_datatype = type_DP;
}
| tok_DOUBLEPRECISION
{
current_datatype = type_DP;
}
| tok_BYTE /* treate BYTE as a form of integer for now */
{
current_datatype = type_INTEGER;
if(f77_standard)
nonstandard($1.line_num,$1.col_num);
}
;
plain_char_type_name: tok_CHARACTER
{
current_datatype = type_STRING;
integer_context = TRUE;
}
;
char_type_name : plain_char_type_name '*' len_specification
{
current_datatype = type_STRING;
}
;
arith_type_decl_list: arith_type_decl_item
| arith_type_decl_list ',' arith_type_decl_item
;
arith_type_decl_item: symbolic_name
{
declare_type(&($1),current_datatype);
}
| array_declarator
{
declare_type(&($1),current_datatype);
}
;
char_type_decl_list: char_type_decl_item
| char_type_decl_list ',' char_type_decl_item
;
char_type_decl_item: symbolic_name
{
declare_type(&($1),current_datatype);
}
| symbolic_name '*' len_specification
{
declare_type(&($1),current_datatype);
}
| array_declarator
{
declare_type(&($1),current_datatype);
}
| array_declarator '*' len_specification
{
declare_type(&($1),current_datatype);
}
;
/* 21 */
/* implicit_flag helps is_keyword's work */
implicit_handle : tok_IMPLICIT {implicit_flag=TRUE;}
;
implicit_stmt : implicit_handle implicit_decl_list EOS
{
{implicit_flag=FALSE;}
if(implicit_none) {
syntax_error($1.line_num,$1.col_num,
"conflicts with IMPLICIT NONE");
}
else {
implicit_type_given = TRUE;
}
}
| implicit_handle tok_identifier EOS
{
int h=$2.value.integer;
{implicit_flag=FALSE;}
if( strcmp(hashtab[h].name,"NONE") == 0 ) {
if(implicit_type_given) {
syntax_error($1.line_num,$1.col_num,
"conflicts with IMPLICIT statement");
}
else {
if(f77_standard)
nonstandard($2.line_num,$2.col_num);
implicit_none = TRUE;
}
}
else {
syntax_error($2.line_num,$2.col_num,
"unknown keyword -- ignored");
}
}
;
implicit_decl_list: implicit_decl_item
| implicit_decl_list ',' {initial_flag = TRUE;}
implicit_decl_item
;
/* implicit_letter_flag tells lexer to treat letters as letters,
not as identifiers */
implicit_decl_item: type_name '(' {implicit_letter_flag = TRUE;}
letter_list ')' {implicit_letter_flag = FALSE;}
;
letter_list : letter_list_item
| letter_list ',' letter_list_item
;
letter_list_item: tok_letter
{
set_implicit_type(current_datatype,
(int)$1.subclass,(int)$1.subclass);
}
| tok_letter '-' tok_letter
{
set_implicit_type(current_datatype,
(int)$1.subclass,(int)$3.subclass);
}
;
/* 22 */
len_specification: '(' '*' ')'
| nonzero_unsigned_int_const
| '(' int_constant_expr ')'
;
/* 23 */
parameter_stmt : tok_PARAMETER '(' parameter_defn_list ')' EOS
;
parameter_defn_list: parameter_defn_item
| parameter_defn_list ',' parameter_defn_item
;
parameter_defn_item: symbolic_name {complex_const_allowed = TRUE;} '='
parameter_expr
{
def_parameter(&($1),&($4));
complex_const_allowed = FALSE;
}
;
/* 24 */
external_stmt : tok_EXTERNAL external_name_list EOS
;
external_name_list: symbolic_name
{
def_ext_name(&($1));
}
| external_name_list ',' symbolic_name
{
def_ext_name(&($3));
}
;
/* 25 */
intrinsic_stmt : tok_INTRINSIC intrinsic_name_list EOS
;
intrinsic_name_list: symbolic_name
{
def_intrins_name(&($1));
}
| intrinsic_name_list ',' symbolic_name
{
def_intrins_name(&($3));
}
;
/* 26 */
save_stmt : tok_SAVE EOS
| tok_SAVE save_list EOS
;
save_list : save_item
| save_list ',' save_item
;
save_item : symbolic_name
{
ref_variable(&($1));
}
| '/' symbolic_name '/'
{
def_com_block(&($2),(Token*)NULL);
}
;
/* 27 */
data_stmt : tok_DATA data_defn_list EOS
;
data_defn_list : data_defn_item
| data_defn_list data_defn_item
| data_defn_list ',' data_defn_item
;
data_defn_item : data_defn_assignee_list '/'
{complex_const_allowed=TRUE;}
data_value_list
{complex_const_allowed=FALSE;} '/'
;
data_defn_assignee_list
: data_defn_assignee
| data_defn_assignee_list ',' data_defn_assignee
;
data_defn_assignee: lvalue
{
use_lvalue(&($1));
}
| data_implied_do_list
;
data_value_list: data_value
| data_value_list ',' data_value
;
data_value : data_constant_value
| data_repeat_factor '*' data_constant_value
;
data_repeat_factor: nonzero_unsigned_int_const
| symbolic_name
{
use_parameter(&($1));
}
;
data_constant_value: constant
| symbolic_name
{
use_parameter(&($1));
}
;
data_dlist : data_dlist_item
| data_dlist ',' data_dlist_item
;
data_dlist_item : array_element_lvalue
{
use_lvalue(&($1));
}
| data_implied_do_list
;
data_implied_do_list: '(' data_dlist ',' symbolic_name
'=' data_do_loop_bounds ')'
{
use_implied_do_index(&($4));
}
;
data_do_loop_bounds: int_constant_expr ',' int_constant_expr
| int_constant_expr ',' int_constant_expr ',' int_constant_expr
;
/* 29 */
assignment_stmt : lvalue '=' {complex_const_allowed = TRUE;} expr
{
assignment_stmt_type(&($1),&($2),
&($4));
complex_const_allowed = FALSE;
}
EOS
{
/* Clear u-b-s flags spuriously set */
if(is_true(STMT_FUNCTION_EXPR, $1.subclass)
&& stmt_sequence_no <= seq_stmt_fun)
stmt_function_stmt(&($1));
}
;
lvalue : variable_name
| array_element_lvalue
| substring_lvalue
| stmt_function_handle
;
/* array-element_lvalue is at 88 */
assign_stmt : tok_ASSIGN pre_label label tok_TO variable_name EOS
{
do_ASSIGN(&($5));
}
;
/* 31 */
unconditional_goto: goto pre_label label EOS
;
/* 32 */
computed_goto : goto '(' goto_list ')' integer_expr EOS
| goto '(' goto_list ')' ',' integer_expr EOS
;
/* 33 */
assigned_goto : goto symbolic_name EOS
{
do_assigned_GOTO(&($2));
}
| goto symbolic_name '(' goto_list ')' EOS
{
do_assigned_GOTO(&($2));
}
| goto symbolic_name ',' '(' goto_list ')' EOS
{
do_assigned_GOTO(&($2));
}
;
goto : tok_GOTO
| tok_GO tok_TO
;
goto_list : pre_label label
| goto_list ',' pre_label label
;
/* 34 */
arithmetic_if_stmt: if_handle pre_label label ',' pre_label label
',' pre_label label EOS
{
int t=datatype_of($1.class);
if(t != type_INTEGER && t != type_REAL
&& t != type_DP && t != type_ERROR ) {
syntax_error($1.line_num,$1.col_num,
"integer, real, or double precision expression required");
}
}
;
/* 35 */
logical_if_stmt : if_handle executable_stmt
{
int t=datatype_of($1.class);
if(t != type_LOGICAL && t != type_ERROR)
syntax_error($1.line_num,$1.col_num,
"logical expression required");
}
;
/* 36 */
block_if_stmt : if_handle tok_THEN EOS
{
int t=datatype_of($1.class);
if(t != type_LOGICAL && t != type_ERROR)
syntax_error($1.line_num,$1.col_num,
"logical expression required");
}
;
if_handle : tok_IF '(' {complex_const_allowed = TRUE;} expr ')'
{
if(is_true(ID_EXPR,$4.subclass)){
use_variable(&($4));
}
complex_const_allowed = FALSE;
initial_flag = TRUE; /* for is_keyword */
$$ = $4; /* Inherit expr for type checking above */
}
;
/* 37 */
else_if_stmt : tok_ELSE block_if_stmt
| tok_ELSEIF '(' {complex_const_allowed = TRUE;} expr ')'
{
if(is_true(ID_EXPR,$4.subclass)){
use_variable(&($4));
}
complex_const_allowed = FALSE;
initial_flag = TRUE;
}
tok_THEN EOS
;
/* 38 */
else_stmt : tok_ELSE EOS
;
/* 39 */
end_if_stmt : tok_ENDIF EOS
| tok_END tok_IF EOS
;
/* 40 */
/* Allow VAX/VMS extensions:
DO [label [,]] var = expr , expr [,expr]
DO [label [,]] WHILE ( expr )
...
ENDDO
*/
do_stmt : do_handle variable_name
'=' do_loop_bounds EOS
{
use_lvalue(&($2));
use_variable(&($2));
/* Check for non-integer DO index or bounds */
if(datatype_of($2.class) == type_INTEGER
&& datatype_of($4.class) != type_INTEGER)
warning($3.line_num,$2.col_num,
"type mismatch between DO index and bounds");
else if(datatype_of($2.class) != type_INTEGER)
if(datatype_of($4.class) != type_INTEGER) {
if(port_check)
nonportable($4.line_num,$4.col_num,
"non-integer DO loop bounds");
}
else {
if(trunc_check)
warning($2.line_num,$2.col_num,
"DO index is not integer");
}
}
| do_handle tok_WHILE '('
{complex_const_allowed=TRUE;} expr ')' EOS
{
if(is_true(ID_EXPR,$5.subclass)){
use_variable(&($5));
}
complex_const_allowed=FALSE;
/* (N.B. nonportability flagged in do_handle) */
}
| tok_DOWHILE '('
{complex_const_allowed=TRUE;} expr ')' EOS
{
if(is_true(ID_EXPR,$4.subclass)){
use_variable(&($4));
}
complex_const_allowed=FALSE;
#ifdef ALLOW_DO_ENDO
if(f77_standard)
nonstandard($1.line_num,$1.col_num);
#else
syntax_error($1.line_num,$1.col_num,
"Nonstandard syntax");
#endif
}
;
do_handle : tok_DO pre_label label
| tok_DO pre_label label ','
| tok_DO pre_label
{
#ifdef ALLOW_DO_ENDO
if(f77_standard)
nonstandard($1.line_num,$1.col_num);
#else
syntax_error($1.line_num,$1.col_num,
"Nonstandard syntax");
#endif
integer_context=FALSE;
}
;
do_loop_bounds : int_real_dp_expr ',' int_real_dp_expr
{
$$.class=do_bounds_type(&($1),&($3),&($3));
}
| int_real_dp_expr ',' int_real_dp_expr ',' int_real_dp_expr
{
$$.class=do_bounds_type(&($1),&($3),&($5));
}
;
enddo_stmt : tok_END tok_DO EOS
{
#ifdef ALLOW_DO_ENDO
if(f77_standard)
nonstandard($2.line_num,$2.col_num);
#else
syntax_error($2.line_num,$2.col_num,
"Nonstandard syntax");
#endif
}
| tok_ENDDO EOS
{
#ifdef ALLOW_DO_ENDO
if(f77_standard)
nonstandard($1.line_num,$1.col_num);
#else
syntax_error($1.line_num,$1.col_num,
"Nonstandard syntax");
#endif
}
;
/* 41 */
continue_stmt : tok_CONTINUE EOS
;
/* 42 */
stop_stmt : tok_STOP stop_info EOS
;
/* 43 */
pause_stmt : tok_PAUSE stop_info EOS
;
stop_info : /* empty */
| tok_integer_const
| symbolic_name
{
use_variable(&($1));
}
| tok_string
;
/* 44 */
write_stmt : write_handle
{complex_const_allowed = FALSE;} EOS
| write_handle io_list
{complex_const_allowed = FALSE;} EOS
;
write_handle : tok_WRITE {control_item_count = 0;}
'(' control_info_list ')'
{complex_const_allowed = TRUE;}
;
/* 45 */
/* Note that parenthesized format_id's will end up in
control_info_list. Disambiguation left to semantic phase.
This is why we need the optional comma */
read_stmt : read_handle '(' control_info_list ')' EOS
| read_handle '(' control_info_list ')' io_list EOS
| read_handle '(' control_info_list ')' ',' io_list EOS
| read_handle format_id EOS
| read_handle format_id ',' io_list EOS
;
read_handle : tok_READ {control_item_count = 0;}
;
accept_stmt : tok_ACCEPT format_id EOS
{
if(f77_standard)
nonstandard($1.line_num,$1.col_num);
}
| tok_ACCEPT format_id ',' io_list EOS
{
if(f77_standard)
nonstandard($1.line_num,$1.col_num);
}
;
/* 46 */
print_stmt : tok_PRINT format_id EOS
| tok_PRINT format_id ','
{complex_const_allowed = TRUE;} io_list
{complex_const_allowed = FALSE;} EOS
;
type_output_stmt: tok_TYPE format_id EOS
{
if(f77_standard)
nonstandard($1.line_num,$1.col_num);
}
| tok_TYPE format_id ','
{complex_const_allowed = TRUE;} io_list
{complex_const_allowed = FALSE;} EOS
{
if(f77_standard)
nonstandard($1.line_num,$1.col_num);
}
;
/* 47 */
control_info_list: control_info_item
{
++control_item_count;
}
| control_info_list ',' control_info_item
{
++control_item_count;
}
;
/* Note that unit id is not distinguished from format id
by the grammar. Use sequence no. to tell which is which.
*/
control_info_item: symbolic_name '=' unit_id
{
use_io_keyword(&($1),&($3),curr_stmt_class);
}
| unit_id
{
if( $1.class != '*'
&& is_true(ID_EXPR,$1.subclass)){
/* WRITE(string,...) means store
output in the string */
if(curr_stmt_class == tok_WRITE
&& control_item_count == 0
&& datatype_of($1.class) == type_STRING)
use_lvalue(&($1));
/* READ/WRITE(..,namelist) means
I/O with variables of namelist. */
else if( control_item_count == 1
&& datatype_of($1.class) == type_NAMELIST)
ref_namelist(&($1),curr_stmt_class);
use_variable(&($1));
}
}
;
/* OPEN stmt needs its own control list defn to
allow for VMS READONLY and similar keywords.
Special prodn for unit_id as optional 1st item
needed to avoid reduce/reduce conflict with
later-occurring symbolic_name items. */
open_info_list : unit_id
{
if( $1.class != '*'
&& is_true(ID_EXPR,$1.subclass)){
use_variable(&($1));
}
++control_item_count;
}
| symbolic_name '=' unit_id
{
use_io_keyword(&($1),&($3),curr_stmt_class);
++control_item_count;
}
| open_info_list ',' open_info_item
{
++control_item_count;
}
;
open_info_item : symbolic_name '=' unit_id
{
use_io_keyword(&($1),&($3),curr_stmt_class);
}
| symbolic_name /* NOSPANBLOCKS, READONLY or SHARED */
{
use_special_open_keywd(&($1));
}
;
/* 48 */
io_list : io_item
| io_list ',' io_item
;
io_item : expr
{
if(is_true(ID_EXPR,$1.subclass)){
if( curr_stmt_class == tok_READ ||
curr_stmt_class == tok_ACCEPT )
use_lvalue(&($1));
else
use_variable(&($1));
}
}
| io_implied_do_list
;
/* 49 */
io_implied_do_list: '(' io_list ',' variable_name '=' do_loop_bounds ')'
{
use_implied_do_index(&($4));
}
;
/* 50 */
open_stmt : tok_OPEN {control_item_count = 0;}
'(' open_info_list ')' EOS
;
/* 51 */
close_stmt : tok_CLOSE {control_item_count = 0;}
'(' control_info_list ')' EOS
;
/* 52 */
inquire_stmt : tok_INQUIRE {control_item_count = 0;}
'(' control_info_list ')' EOS
;
/* 53 */
backspace_stmt : backspace_handle unit_id EOS
| backspace_handle '(' control_info_list ')' EOS
;
backspace_handle: tok_BACKSPACE {control_item_count = 0;}
;
/* 54 */
endfile_stmt : endfile_handle unit_id EOS
| endfile_handle '(' control_info_list ')' EOS
;
endfile_handle : tok_ENDFILE {control_item_count = 0;}
| tok_END tok_FILE {control_item_count = 0;}
;
/* 55 */
rewind_stmt : rewind_handle unit_id EOS
| rewind_handle '(' control_info_list ')' EOS
;
rewind_handle : tok_REWIND {control_item_count = 0;}
;
/* 56 */
/* "expr" causes shift/reduce conflict on ')' between
red'n unit_id: expr_ and shift primary: ( expr_ ).
Use "associativity" rule to force reduction */
unit_id : expr %prec REDUCE
| '*'
;
/* 57 */
format_id : char_expr
{
if(is_true(ID_EXPR,$1.subclass)){
use_variable(&($1));
}
}
| '*'
;
/* 58,59 */
format_stmt : tok_FORMAT {inside_format=TRUE;} '(' format_spec ')' EOS
{
inside_format=FALSE;
}
;
/* 60-69 */
format_spec : /* EMPTY */
| format_spec fmt_spec_item
| format_spec ',' fmt_spec_item
;
fmt_spec_item : repeatable_fmt_item
| repeat_spec repeatable_fmt_item
| unrepeatable_fmt_item
;
repeatable_fmt_item: '(' format_spec ')'
| tok_edit_descriptor
;
unrepeatable_fmt_item: tok_string
| tok_hollerith
| '/'
| tok_concat /* since lexer spots "//" */
| ':'
| nonstandard_fmt_item
{
if(f77_standard)
nonstandard($1.line_num,$1.col_num);
}
;
nonstandard_fmt_item: '$' /* VMS uses this */
;
repeat_spec : tok_integer_const
| '-' tok_integer_const /* for kP descriptor */
| '+' tok_integer_const /* for +kP descriptor */
;
/* 70 handle only: complete defn handled as assignment stmt */
stmt_function_handle: scalar_name '(' stmt_function_dummy_list ')'
{
if(stmt_sequence_no > seq_stmt_fun) {
syntax_error(
$1.line_num, NO_COL_NUM,
"statement out of order");
}
def_stmt_function(&($1),&($3));
/* make token info */
primary_id_expr(&($1),&($$));
if(debug_parser)
print_exprlist("stmt function",&($3));
}
;
stmt_function_dummy_list: stmt_function_dummy_arg
{
$$.next_token = append_token((Token*)NULL,&($1));
}
| stmt_function_dummy_list ',' stmt_function_dummy_arg
{
$$.next_token = append_token($1.next_token,&($3));
}
;
stmt_function_dummy_arg: variable_name /* for now: later, handle correctly */
;
/* 71 */
call_stmt : call_handle
{
call_subr(&($1),(Token*)NULL);
complex_const_allowed = FALSE;
} EOS
| call_handle '(' ')'
{
call_subr(&($1),(Token*)NULL);
complex_const_allowed = FALSE;
} EOS
| call_handle '(' expr_list ')'
{
call_subr(&($1),&($3));
if(debug_parser)
print_exprlist("call stmt",&($3));
complex_const_allowed = FALSE;
} EOS
;
call_handle : tok_CALL symbolic_name
{
complex_const_allowed = TRUE;
$$ = $2;
}
;
expr_list : expr
{
if(is_true(ID_EXPR,$1.subclass)){
use_actual_arg(&($1));
use_variable(&($1));
}
$$.next_token = append_token((Token*)NULL,&($1));
}
| '*' pre_label label
{
$$.next_token = append_token((Token*)NULL,&($3));
}
| expr_list ',' expr
{
if(is_true(ID_EXPR,$3.subclass)){
use_actual_arg(&($3));
use_variable(&($3));
}
$$.next_token = append_token($1.next_token,&($3));
}
| expr_list ',' '*' pre_label label
{
$$.next_token = append_token($1.next_token,&($5));
}
;
/* 72 */
return_stmt : tok_RETURN EOS
{
do_RETURN(current_module_hash,&($1));
}
| tok_RETURN integer_expr EOS
{
do_RETURN(current_module_hash,&($1));
}
;
/* 73 */
function_reference: fun_or_substr_handle '(' fun_arg_list ')'
{
/* restore status of complex flag */
if(!is_true(COMPLEX_FLAG,$1.subclass))
complex_const_allowed=FALSE;
call_func(&($1),&($3));
/* make token info */
func_ref_expr(&($1),&($3),&($$));
if(debug_parser)
print_exprlist("function",&($3));
}
;
fun_or_substr_handle: scalar_name
{
if(complex_const_allowed)/* save context */
make_true(COMPLEX_FLAG,$$.subclass);
complex_const_allowed=TRUE;
}
;
fun_arg_list : /* empty */
{
$$.class = 0;
$$.next_token = NULL;
}
| nonempty_fun_arg_list
;
nonempty_fun_arg_list: expr
{
$$.next_token = append_token((Token*)NULL,&($1));
}
| fun_arg_list ',' expr
{
$$.next_token = append_token($1.next_token,&($3));
}
/* 74 not present: type checking not done at this level */
/* 75 was constant_expr, but only used by PARAMETER */
parameter_expr : /* arith, char, or logical */ expr
{
if(datatype_of($1.class) != type_ERROR){
if( ! is_const_type($1.class) ) {
syntax_error($1.line_num,$1.col_num,
"arithmetic, char, or logical expression expected");
}
else {
if( !is_true(PARAMETER_EXPR,$1.subclass) ) {
syntax_error($1.line_num,$1.col_num,
"constant expression expected");
}
/* Here we allow, with some warnings, expr
containing intrins func or **REAL in
PARAMETER defn. */
else if( !is_true(CONST_EXPR,$1.subclass) ) {
if(f77_standard) {
nonstandard($1.line_num,$1.col_num);
msg_tail(
"\n intrinsic func or **REAL in PARAMETER defn");
}
}
}
}
}
;
/* 76 following the text of the standard, not the diagrams */
expr : log_expr
{
if(debug_parser) {
fprintf(list_fd,
"\nexpr: class=0x%x subclass=0x%x",
$1.class,
$1.subclass);
}
}
;
log_expr : log_disjunct
| expr tok_EQV log_disjunct
{
binexpr_type(&($1),&($2),&($3)
,&($$));
}
| expr tok_NEQV log_disjunct
{
binexpr_type(&($1),&($2),&($3)
,&($$));
}
;
log_disjunct : log_term
| log_disjunct tok_OR log_term
{
binexpr_type(&($1),&($2),&($3)
,&($$));
}
;
log_term : log_factor
| log_term tok_AND log_factor
{
binexpr_type(&($1),&($2),&($3)
,&($$));
}
;
log_factor : log_primary
| tok_NOT log_primary
{
unexpr_type(&($1),&($2),&($$));
}
;
log_primary : arith_expr
| log_primary tok_relop log_primary
{
binexpr_type(&($1),&($2),&($3)
,&($$));
}
;
arith_expr : term
| '-' term
{
unexpr_type(&($1),&($2),&($$));
}
| '+' term
{
unexpr_type(&($1),&($2),&($$));
}
| arith_expr '+' term
{
binexpr_type(&($1),&($2),&($3)
,&($$));
}
| arith_expr '-' term
{
binexpr_type(&($1),&($2),&($3)
,&($$));
}
;
term : factor
| term '/' factor
{
binexpr_type(&($1),&($2),&($3)
,&($$));
if(div_check &&
!is_true(CONST_EXPR,$3.subclass)){
warning($2.line_num,$2.col_num,
"Possible division by zero");
}
}
| term '*' factor
{
binexpr_type(&($1),&($2),&($3)
,&($$));
}
;
factor : char_expr
| char_expr tok_power factor
{
binexpr_type(&($1),&($2),&($3)
,&($$));
}
;
char_expr : primary
| char_expr tok_concat primary
{
binexpr_type(&($1),&($2),&($3)
,&($$));
}
;
primary : variable_name
{
DBGstr(primary<--id=,token_name($1));
}
| array_element_name
| function_reference
| substring_name
| numeric_const
{
make_true(CONST_EXPR,$$.subclass);
make_true(PARAMETER_EXPR,$$.subclass);
make_true(NUM_CONST,$$.subclass);
}
| tok_string
{
DBGstr(primary<--str=,$1.value.string)
$$.class = type_byte(class_VAR,type_STRING);
$$.subclass = 0;
make_true(CONST_EXPR,$$.subclass);
make_true(PARAMETER_EXPR,$$.subclass);
}
| tok_hollerith
{
DBGstr(primary<--h=,$1.value.string)
$$.class = type_byte(class_VAR,type_HOLLERITH);
$$.subclass = 0;
make_true(CONST_EXPR,$$.subclass);
make_true(PARAMETER_EXPR,$$.subclass);
if(port_check && hollerith_check) {
warning($1.line_num,$1.col_num,
"hollerith constant may not be portable");
}
}
| tok_logical_const
{
DBGstr(primary<--log=,$1.value.string)
$$.class = type_byte(class_VAR,type_LOGICAL);
$$.subclass = 0;
make_true(CONST_EXPR,$$.subclass);
make_true(PARAMETER_EXPR,$$.subclass);
}
| '(' expr ')'
{
$$ = $2;
}
;
numeric_const : tok_integer_const
{
$$.class = type_byte(class_VAR,type_INTEGER);
$$.subclass = 0;
}
| tok_real_const
{
$$.class = type_byte(class_VAR,type_REAL);
$$.subclass = 0;
}
| tok_dp_const
{
$$.class = type_byte(class_VAR,type_DP);
$$.subclass = 0;
}
| tok_complex_const
{
$$.class = type_byte(class_VAR,type_COMPLEX);
$$.subclass = 0;
}
;
/* 77 */
integer_expr : /* integer */ arith_expr
{
if(is_true(ID_EXPR,$1.subclass)){
use_variable(&($1));
}
if(datatype_of($1.class) != type_INTEGER) {
syntax_error(
$1.line_num,$1.col_num,
"expression must be integer type");
}
}
;
/* 78 */
int_real_dp_expr: /* integer, real, or double */ arith_expr
{
if(is_true(ID_EXPR,$1.subclass)){
use_variable(&($1));
}
{
int t=datatype_of($1.class);
if(t != type_INTEGER && t != type_REAL
&& t != type_DP ) {
syntax_error(
$1.line_num,$1.col_num,
"expression must be integer, real, or double precision type");
}
}
}
;
/* 79 absent */
/* 80 */
int_constant_expr: /* integer const */ arith_expr
{
if(is_true(ID_EXPR,$1.subclass)){
use_variable(&($1));
}
if( ! is_true(CONST_EXPR,$1.subclass) ) {
syntax_error(
$1.line_num,$1.col_num,
"constant expression expected");
}
else
if(datatype_of($1.class) != type_INTEGER){
syntax_error(
$1.line_num,$1.col_num,
"integer expression expected");
}
}
;
/* 81 */
dim_bound_expr : /* integer */ arith_expr
{
if(is_true(ID_EXPR,$1.subclass)){
use_variable(&($1));
}
if( datatype_of($1.class) != type_INTEGER ){
syntax_error(
$1.line_num,$1.col_num,
"integer dimension expected");
$$.value.integer = 0;
}
else {
if( is_true(CONST_EXPR,$1.subclass) )
$$.value.integer =
int_expr_value(&($1));
else /* must be dummy */
$$.value.integer = 0;
}
}
;
/* 82-85 absent: no type checking here */
/* 86-87 absent: see 76 */
/* 88 */
array_element_lvalue: array_name '(' subscript_list ')'
{
ref_array(&($1),&($3));
if(debug_parser)
print_exprlist("array lvalue",&($3));
/* array now becomes scalar */
make_false(ARRAY_ID_EXPR,$$.subclass);
}
;
array_element_name: array_name '(' subscript_list ')'
{
ref_array(&($1),&($3));
if(debug_parser)
print_exprlist("array",&($3));
/* array now becomes scalar */
make_false(ARRAY_ID_EXPR,$$.subclass);
}
;
subscript_list : subscript
{
$$.next_token = append_token((Token*)NULL,&($1));
}
| subscript_list ',' subscript
{
$$.next_token = append_token($1.next_token,&($3));
}
;
subscript : expr
{
if(is_true(ID_EXPR,$1.subclass)){
use_variable(&($1));
}
/* check subscript exprs for integer type */
if(datatype_of($1.class) != type_INTEGER)
if(trunc_check)
warning($1.line_num,$1.col_num,
"subscript is not integer");
}
;
/* 89 */
substring_name : fun_or_substr_handle substring_interval
{
/* restore status of complex flag */
if(!is_true(COMPLEX_FLAG,$1.subclass))
complex_const_allowed=FALSE;
}
| array_element_name substring_interval
;
substring_lvalue: scalar_name substring_interval
| array_element_lvalue substring_interval
;
substring_interval: '(' ':' ')'
| '(' arith_expr ':' ')'
{
if(is_true(ID_EXPR,$2.subclass)){
use_variable(&($2));
}
}
| '(' ':' arith_expr ')'
{
if(is_true(ID_EXPR,$3.subclass)){
use_variable(&($3));
}
}
| '(' arith_expr ':' arith_expr ')'
{
if(is_true(ID_EXPR,$2.subclass)){
use_variable(&($2));
}
if(is_true(ID_EXPR,$4.subclass)){
use_variable(&($4));
}
}
;
/* 90-98 absent: name categories not distinguished */
/* 99 */
variable_name : scalar_name
| array_name
;
scalar_name : tok_identifier
{
ref_variable(&($1));
primary_id_expr(&($1),&($$));
}
;
array_name : tok_array_identifier
{
ref_variable(&($1));
primary_id_expr(&($1),&($$));
}
;
/* symbolic_name refers to a name without making it into an id expr */
symbolic_name : tok_identifier
| tok_array_identifier
;
/* 100 */
constant : numeric_const
| '-' numeric_const
| '+' numeric_const
| tok_logical_const
| tok_string
| tok_hollerith
;
/* 101-102 absent */
/* 103 */
nonzero_unsigned_int_const:
tok_integer_const
;
/* 104-109 absent: lexer handles these */
/* pre_label prepares for an expected label by setting flag
so that lexer won't look for E-format number. All grammar
rules that have "label" precede it with "pre_label" */
pre_label : /* NOTHING */
{
integer_context=TRUE;
}
;
/* 110 */
label : tok_integer_const
{
integer_context=FALSE;
$$.class = type_byte(class_LABEL,type_LABEL);
$$.subclass = 0;
}
;
/* 111-116 absent: lexer handles these */
%%
void
init_parser() /* Initialize various flags & counters */
{
initial_flag = TRUE; /* set flag for keyword test */
implicit_flag=FALSE; /* clear flags for IMPLICIT stmt */
implicit_letter_flag = FALSE;
implicit_type_given = FALSE;
implicit_none = FALSE;
prev_token_class = EOS;
complex_const_allowed = FALSE;
stmt_sequence_no = 0;
}
/* Propagate non-integer type if any of DO loop
bounds are non-integer. */
PRIVATE int
do_bounds_type(t1,t2,t3)
Token *t1, *t2, *t3;
{
int result_class;
if(datatype_of(t1->class) != type_INTEGER) result_class = t1->class;
else if(datatype_of(t2->class) != type_INTEGER) result_class = t2->class;
else if(datatype_of(t3->class) != type_INTEGER) result_class = t3->class;
else result_class = t1->class;
return result_class;
}
/* Debugging routine: prints the expression list of various productions */
PRIVATE void
print_exprlist(s,t)
char *s;
Token *t;
{
fprintf(list_fd,"\n%s arglist: ",s);
if(t == NULL)
fprintf(list_fd,"(empty)");
else {
while( (t=t->next_token) != NULL) {
fprintf(list_fd,"%s ",type_name[datatype_of(t->class)]);
if( is_true(ID_EXPR,t->subclass) )
fprintf(list_fd,"(%s) ",token_name(*t));
}
}
}
PRIVATE void
print_comlist(s,t)
char *s;
Token *t;
{
fprintf(list_fd,"\n%s varlist: ",s);
if(t == NULL)
fprintf(list_fd,"(empty)");
else {
while( (t=t->next_token) != NULL) {
fprintf(list_fd,"%s ",type_name[datatype_of(t->class)]);
if( is_true(ID_EXPR,t->subclass) )
fprintf(list_fd,"(%s) ",token_name(*t));
}
}
}
/* After having parsed prog_stmt, function_stmt, subroutine_stmt,
block_data_stmt, the stmt_sequence_no is set to the value seq_header.
*/
void
check_seq_header(t)
Token *t;
{
if(stmt_sequence_no >= seq_header) {
syntax_error( (t == (Token *) NULL? line_num: t->line_num),
NO_COL_NUM,
"missing END statement inserted");
msg_tail( (t == (Token *) NULL? "at end of file":
"prior to statement") );
END_processing(t);
}
stmt_sequence_no = seq_header;
}
/* After having parsed end_stmt, common block lists and
subprogram argument lists are copied over into global symbol
table, the local symbol table is printed out and then cleared,
and stmt_sequence_no is set to zero for start of next module.
*/
PRIVATE void
END_processing(t)
Token *t;
{
if(current_module_hash != -1) {
if(exec_stmt_count == 0 &&
current_module_type != type_BLOCK_DATA) {
warning(t == (Token *)NULL? line_num: t->line_num, NO_COL_NUM,
"Module contains no executable statements");
}
if(do_list && t != (Token *)NULL)
flush_line_out(t->line_num);
process_lists(current_module_hash);
debug_symtabs();
print_loc_symbols(current_module_hash);
init_symtab();
}
exec_stmt_count = 0;
stmt_sequence_no = 0;
current_module_hash = -1;
implicit_type_given = FALSE;
implicit_none = FALSE;
}
/* Routine to add token t to the front of a token list. */
PRIVATE Token *
append_token(tlist,t)
Token *tlist, *t;
{
Token *tcopy;
if((tcopy=new_token()) == (Token *)NULL){
fprintf(stderr,
"Oops--Out of token space at line %u\n",
line_num);
#ifdef LARGE_MACHINE
fprintf(stderr,
"Recompile me with larger TOKENSPACESZ value\n");
#else
fprintf(stderr,
"Recompile me with LARGE_MACHINE option\n");
#endif
exit(1);
}
*tcopy = *t; /* make permanent copy of token */
tcopy->next_token = tlist; /* link it onto front of list */
return tcopy; /* return it as new tlist */
}