Alexander_KS/SAPFOR
4
2
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity
Files
3c1032bfd0c00ccea056f4afbc667b77d91bb01b
SAPFOR/projects/dvm_svn/fdvm/trunk/parser/stat.c

1450 lines
39 KiB
C
Raw Normal View History

added project
2023-09-14 19:43:13 +03:00
/*********************************************************************/
/* pC++/Sage++ Copyright (C) 1993 */
/* Indiana University University of Oregon University of Rennes */
/*********************************************************************/
#define EXTEND_NODE 2 /* move this definition to h/ files. */
/* should agree with cftn.gram definition. */
/*
* stat.c
*
* Routines for handling Fortran statements
*
*/
#include "inc.h"
#include "defines.h"
#include "extern.h"
#ifdef SYS5
#include <string.h>
#else
#include <strings.h>
#endif
extern int parstate;
extern PTR_SYMB head_symb, global_list, star_symb;
extern PTR_BFND cur_bfnd, global_bfnd, pred_bfnd, cur_scope();
extern PTR_BFND last_bfnd; /*OMP*/
extern PTR_TYPE global_float, global_int, global_bool, global_default, vartype;
extern PTR_LABEL head_label;
extern PTR_LABEL thislabel;
extern PTR_TYPE impltype[];
extern PTR_BLOB head_blob, cur_blob;
extern PTR_CMNT comments;
extern int yylineno;
extern int mod_offset;
extern int nioctl;
extern int yydebug;
void fatalstr();
void execerr();
int chk_params();
void err();
void setimpl();
PTR_BFND get_bfnd();
PTR_LLND make_llnd();
PTR_SYMB make_symb();
PTR_BLOB make_blob();
PTR_LABEL make_label();
PTR_SYMB install_entry();
PTR_SYMB get_proc_symbol();
PTR_HASH correct_symtab();
int end_group = 0;
/*
The following two routines are used for reading in input/output
control lists.
*/
void
startioctl()
{
inioctl = YES;
nioctl = 0;
}
void
endioctl()
{
inioctl = NO;
}
/*
* Follow a chain of blob nodes to get the last
*
* input:
* blob - the list to be searched
*
* output:
* pointer to the last node in the list
*/
PTR_BLOB
follow_blob(blob)
PTR_BLOB blob;
{
register PTR_BLOB next, last;
for (next = last = blob; next; next = next->next)
last = next;
return (last);
}
/*
* make_if takes an expression to make an IF_NODE
* Also allocates a collection point and points the false branch
* to the collection point
*/
PTR_BFND
make_if(expr)
PTR_LLND expr;
{
PTR_BFND p;
void set_blobs(), make_prog_header();
void err();
/*
if (pred_bfnd->variant == GLOBAL)
make_prog_header();
*/
/* if (expr->type->variant != T_BOOL) {
err("Non-logical expression in IF statement", 28);
expr = LLNULL;
}
*/ /*06.06.03*/
p = get_bfnd(fi,IF_NODE, SMNULL, expr, LLNULL, LLNULL);
/* set_blobs(p, pred_bfnd, NEW_GROUP1); */
return (p);
}
PTR_BFND
make_forall(lexpr,expr)
PTR_LLND expr,lexpr;
{
PTR_BFND p;
void set_blobs(), make_prog_header();
void err();
/*
if (pred_bfnd->variant == GLOBAL)
make_prog_header();
*/
/* if (expr && expr->type->variant != T_BOOL) {
err("Non-logical expression in FORALL statement", 288);
expr = LLNULL;
}
*/ /*06.06.03*/
p = get_bfnd(fi,FORALL_NODE, SMNULL, lexpr, expr, LLNULL);
/* set_blobs(p, pred_bfnd, NEW_GROUP1); */
return (p);
}
/*
* make_elseif fixes the control frame to reflect the current paring state
*/
void
make_elseif(expr,s)
PTR_LLND expr;
PTR_SYMB s; /*podd 3.02.03*/
{
register PTR_BFND p = NULL;
void execerr(), make_endblock();
/* if (expr->type->variant != T_BOOL) {
err("Non-logical expression in IF statement", 28);
expr = LLNULL;
}
*/ /*06.06.03*/
if (pred_bfnd->variant == IF_NODE || pred_bfnd->variant == ELSEIF_NODE)
p = get_bfnd(fi,ELSEIF_NODE, s, expr, LLNULL, LLNULL);
else
err("ELSEIF out of place", 31);
p->control_parent = pred_bfnd;
pred_bfnd->entry.Template.bl_ptr2 = make_blob(fi,p, BLNULL);
pred_bfnd = p;
cur_blob = p->entry.Template.bl_ptr1 = make_blob(fi,BFNULL, BLNULL);
}
void
make_elsewhere_mask(expr,s)
PTR_LLND expr;
PTR_SYMB s; /*podd 15.02.03*/
{
register PTR_BFND p = NULL;
void execerr(), make_endblock();
/*if (expr->type->variant != T_BOOL) {
err("Non-logical expression in IF statement", 28);
expr = LLNULL;
}*/
if (pred_bfnd->variant == WHERE_BLOCK_STMT || pred_bfnd->variant == ELSEWH_NODE)
p = get_bfnd(fi,ELSEWH_NODE, s, expr, LLNULL, LLNULL);
else
err("ELSEWHERE out of place", 291);
p->control_parent = pred_bfnd;
pred_bfnd->entry.Template.bl_ptr2 = make_blob(fi,p, BLNULL);
pred_bfnd = p;
cur_blob = p->entry.Template.bl_ptr1 = make_blob(fi,BFNULL, BLNULL);
}
/*
* make_else fixes the control stack to reflect the current state of parsing
* and put all BIF nodes after the saved control frame as the true branch of
* the If statement
*/
void
make_else(s)
PTR_SYMB s; /*podd 3.02.03*/
{
void execerr(), set_blobs();
PTR_BFND p;
if (pred_bfnd->variant != IF_NODE && pred_bfnd->variant != ELSEIF_NODE)
err("ELSE out of place", 32);
p = get_bfnd(fi,CONTROL_END, s, LLNULL, LLNULL, LLNULL);
if (is_openmp_stmt) { /*OMP*/
is_openmp_stmt = 0; /*OMP*/
p -> decl_specs = BIT_OPENMP; /*OMP*/
} /*OMP*/
set_blobs(p, pred_bfnd, SAME_GROUP);
cur_blob = pred_bfnd->entry.Template.bl_ptr2
= make_blob(fi,BFNULL, BLNULL);
}
void
make_elsewhere(s)
PTR_SYMB s; /*15.02.03*/
{
void execerr(), set_blobs();
PTR_BFND p;
if (pred_bfnd->variant != WHERE_BLOCK_STMT && pred_bfnd->variant != ELSEWH_NODE)
err("ELSEWHERE out of place", 291 );
p = get_bfnd(fi,CONTROL_END, s, LLNULL, LLNULL, LLNULL);
if (is_openmp_stmt) { /*OMP*/
is_openmp_stmt = 0; /*OMP*/
p -> decl_specs = BIT_OPENMP; /*OMP*/
} /*OMP*/
set_blobs(p, pred_bfnd, SAME_GROUP);
cur_blob = pred_bfnd->entry.Template.bl_ptr2
= make_blob(fi,BFNULL, BLNULL);
}
/*
* make_endblock sets up the statement list to the proper branch according
* to the control stack's status and then pop the control stack.
*/
void
make_endblock(p)
PTR_BFND p;
{
PTR_BFND past_pred;
PTR_BLOB q;
void set_blobs();
if ((pred_bfnd==BFNULL) || (pred_bfnd->control_parent==BFNULL))
fatalstr("Illegal end of block",(char *)NULL,258);
if (cur_blob->ref==BFNULL) { /* empty block body */
/* pred_bfnd->entry.Template.bl_ptr1 = BLNULL; */
cur_blob->ref = p;
}
else
if (p) set_blobs(p, pred_bfnd, SAME_GROUP);
past_pred = pred_bfnd;
pred_bfnd = pred_bfnd->control_parent;
if (pred_bfnd->variant == GLOBAL) parstate = OUTSIDE;
q = follow_blob(pred_bfnd->entry.Template.bl_ptr1);
cur_blob = (q && (q->ref == past_pred)) ?
q
:follow_blob(pred_bfnd->entry.Template.bl_ptr2);
}
void
make_endif(s)
PTR_SYMB s; /*podd 3.02.03*/
{
PTR_BFND p, past_pred;
PTR_BLOB q;
void set_blobs();
if ((pred_bfnd==BFNULL) || (pred_bfnd->control_parent==BFNULL)
|| ((pred_bfnd->variant != IF_NODE) &&
(pred_bfnd->variant != ELSEIF_NODE))) {
fatalstr("Illegal END IF", (char *)NULL, 260);
}
if ((!cur_blob->ref) || (cur_blob->ref->variant != CONTROL_END)) {
p = get_bfnd(fi,CONTROL_END, s, LLNULL, LLNULL, LLNULL);
p = get_bfnd(fi,CONTROL_END, s, LLNULL, LLNULL, LLNULL);
if (is_openmp_stmt) { /*OMP*/
is_openmp_stmt = 0; /*OMP*/
p -> decl_specs = BIT_OPENMP; /*OMP*/
} /*OMP*/
/*change by podd*/
if(thislabel){
thislabel->statbody = p;
thislabel->labtype = LABEXEC;
p->label = thislabel;
}
set_blobs(p, pred_bfnd, SAME_GROUP);
}
while (pred_bfnd->variant == ELSEIF_NODE)
pred_bfnd = pred_bfnd->control_parent;
past_pred = pred_bfnd;
pred_bfnd = pred_bfnd->control_parent;
q = follow_blob(pred_bfnd->entry.Template.bl_ptr1);
cur_blob = (q && (q->ref == past_pred)) ?
q
:follow_blob(pred_bfnd->entry.Template.bl_ptr2);
/* cur_blob = follow_blob(pred_bfnd->entry.Template.bl_ptr1);*/
}
void
make_endwhere(s)
PTR_SYMB s; /*15.02.03*/
{
PTR_BFND p, past_pred;
PTR_BLOB q;
void set_blobs();
if ((pred_bfnd==BFNULL) || (pred_bfnd->control_parent==BFNULL)
|| ((pred_bfnd->variant != WHERE_BLOCK_STMT) &&
(pred_bfnd->variant != ELSEWH_NODE))) {
fatalstr("Illegal ENDWHERE", (char *)NULL, 290);
}
if ((!cur_blob->ref) || (cur_blob->ref->variant != CONTROL_END)) {
p = get_bfnd(fi,CONTROL_END, s, LLNULL, LLNULL, LLNULL);
if (is_openmp_stmt) { /*OMP*/
is_openmp_stmt = 0; /*OMP*/
p -> decl_specs = BIT_OPENMP; /*OMP*/
} /*OMP*/
set_blobs(p, pred_bfnd, SAME_GROUP);
/*change by podd*/
if(thislabel){
thislabel->statbody = p;
thislabel->labtype = LABEXEC;
p->label = thislabel;
}
}
/* pred_bfnd = pred_bfnd->control_parent;*/
/* cur_blob = follow_blob(pred_bfnd->entry.Template.bl_ptr1);*/
while (pred_bfnd->variant == ELSEWH_NODE)
pred_bfnd = pred_bfnd->control_parent;
past_pred = pred_bfnd;
pred_bfnd = pred_bfnd->control_parent;
q = follow_blob(pred_bfnd->entry.Template.bl_ptr1);
cur_blob = (q && (q->ref == past_pred)) ?
q
:follow_blob(pred_bfnd->entry.Template.bl_ptr2);
}
void
make_endforall(s)
PTR_SYMB s;
{
PTR_BFND p, past_pred;
PTR_BLOB q;
void set_blobs();
if ((pred_bfnd==BFNULL) || (pred_bfnd->control_parent==BFNULL)
|| (pred_bfnd->variant != FORALL_NODE)) {
fatalstr("Illegal ENDFORALL", (char *)NULL, 289);
}
if ((!cur_blob->ref) || (cur_blob->ref->variant != CONTROL_END)) {
p = get_bfnd(fi,CONTROL_END, s, LLNULL, LLNULL, LLNULL);
if (is_openmp_stmt) { /*OMP*/
is_openmp_stmt = 0; /*OMP*/
p -> decl_specs = BIT_OPENMP; /*OMP*/
} /*OMP*/
set_blobs(p, pred_bfnd, SAME_GROUP);
/*change by podd*/
if(thislabel){
thislabel->statbody = p;
thislabel->labtype = LABEXEC;
p->label = thislabel;
}
}
past_pred = pred_bfnd;
pred_bfnd = pred_bfnd->control_parent;
q = follow_blob(pred_bfnd->entry.Template.bl_ptr1);
cur_blob = (q && (q->ref == past_pred)) ?
q
:follow_blob(pred_bfnd->entry.Template.bl_ptr2);
}
void
make_endselect(s)
PTR_SYMB s;
{
PTR_BFND p, past_pred;
PTR_BLOB q;
void set_blobs();
if ((pred_bfnd==BFNULL) || (pred_bfnd->control_parent==BFNULL)
|| (pred_bfnd->variant != SWITCH_NODE)) {
fatalstr("Illegal ENDSELECT", (char *)NULL, 286);
}
if ((!cur_blob->ref) || (cur_blob->ref->variant != CONTROL_END)) {
p = get_bfnd(fi,CONTROL_END, s, LLNULL, LLNULL, LLNULL);
if (is_openmp_stmt) { /*OMP*/
is_openmp_stmt = 0; /*OMP*/
p -> decl_specs = BIT_OPENMP; /*OMP*/
} /*OMP*/
set_blobs(p, pred_bfnd, SAME_GROUP);
if(thislabel){
thislabel->statbody = p;
thislabel->labtype = LABEXEC;
p->label = thislabel;
}
}
past_pred = pred_bfnd;
pred_bfnd = pred_bfnd->control_parent;
q = follow_blob(pred_bfnd->entry.Template.bl_ptr1);
cur_blob = (q && (q->ref == past_pred)) ?
q
:follow_blob(pred_bfnd->entry.Template.bl_ptr2);
}
void
make_endextend()
{
PTR_BFND p;
void set_blobs();
if ((pred_bfnd==BFNULL) || (pred_bfnd->control_parent==BFNULL)
|| ((pred_bfnd->variant != PDO_NODE) &&
(pred_bfnd->variant != PSECTIONS_NODE))) {
/* fatalstr("Illegal end extend[ed] statement\n", (char *)NULL);*/
}
if ((!cur_blob->ref) || (cur_blob->ref->variant != CONTROL_END)) {
p = get_bfnd(fi,CONTROL_END, SMNULL, LLNULL, LLNULL, LLNULL);
if (is_openmp_stmt) { /*OMP*/
is_openmp_stmt = 0; /*OMP*/
p -> decl_specs = BIT_OPENMP; /*OMP*/
} /*OMP*/
set_blobs(p, pred_bfnd, SAME_GROUP);
}
pred_bfnd = pred_bfnd->control_parent;
cur_blob = follow_blob(pred_bfnd->entry.Template.bl_ptr1);
if (cur_blob->ref->variant == CONTROL_END)
cur_blob = follow_blob(pred_bfnd->entry.Template.bl_ptr2);
}
/* 18th, Dec. 90 */
/* modified to take care of PCF FORTRAN's variety of END statements */
PTR_BFND
make_enddoall()
{
PTR_BFND p = get_bfnd(fi,CONTROL_END, SMNULL, LLNULL, LLNULL, LLNULL);
PTR_BLOB q;
if (is_openmp_stmt) { /*OMP*/
is_openmp_stmt = 0; /*OMP*/
p -> decl_specs = BIT_OPENMP; /*OMP*/
} /*OMP*/
if ((!pred_bfnd) ||
((pred_bfnd->variant != CDOALL_NODE) &&
(pred_bfnd->variant != SDOALL_NODE) &&
(pred_bfnd->variant != DOACROSS_NODE) &&
(pred_bfnd->variant != CDOACROSS_NODE) &&
(pred_bfnd->variant != PARDO_NODE) &&
(pred_bfnd->variant != PROCESS_DO_STAT) &&
(pred_bfnd->variant != PDO_NODE)))
execerr("enddoall statement out of place", (char *)NULL);
q = follow_blob(pred_bfnd->entry.Template.bl_ptr1);
if (q != cur_blob) {
pred_bfnd->entry.Template.bl_ptr1 =
pred_bfnd->entry.Template.bl_ptr2;
pred_bfnd->entry.Template.bl_ptr2 = BLNULL;
}
return p;
}
PTR_BFND
make_endprocesses()
{
PTR_BFND p = get_bfnd(fi,PROCESSES_END, SMNULL, LLNULL, LLNULL, LLNULL);
PTR_BLOB q;
if ((!pred_bfnd) || (pred_bfnd->variant != PROCESSES_STAT))
execerr("endprocesses statement out of place", (char *)NULL);
q = follow_blob(pred_bfnd->entry.Template.bl_ptr1);
if (q != cur_blob) {
pred_bfnd->entry.Template.bl_ptr1 =
pred_bfnd->entry.Template.bl_ptr2;
pred_bfnd->entry.Template.bl_ptr2 = BLNULL;
}
return p;
}
void
make_loop()
{
PTR_BFND p;
void set_blobs();
if ((pred_bfnd->variant != CDOALL_NODE) &&
(pred_bfnd->variant != SDOALL_NODE) &&
(pred_bfnd->variant != DOACROSS_NODE) &&
(pred_bfnd->variant != CDOACROSS_NODE))
execerr("loop statement out of place", (char *)NULL);
p = get_bfnd(fi,CONTROL_END, SMNULL, LLNULL, LLNULL, LLNULL);
if (is_openmp_stmt) { /*OMP*/
is_openmp_stmt = 0; /*OMP*/
p -> decl_specs = BIT_OPENMP; /*OMP*/
} /*OMP*/
set_blobs(p, pred_bfnd, SAME_GROUP);
cur_blob = pred_bfnd->entry.Template.bl_ptr1
= make_blob(fi,(PTR_BFND) NULL, (PTR_BLOB) NULL);
}
/*
* Setup of logical IF statement
*/
PTR_BFND
make_logif(if_stmt, body)
PTR_BFND if_stmt, body;
{
/*PTR_BFND temp;*/
PTR_BLOB new_blob;
void set_blobs(), make_prog_header();
/*
if (expr->type->variant != T_BOOL) {
err("non-logical expression in IF statement");
expr = LLNULL;
}
if (pred_bfnd->variant == GLOBAL)
make_prog_header();
temp = get_bfnd(fi,LOGIF_NODE, SMNULL, expr, LLNULL, LLNULL);
set_blobs(temp, pred_bfnd, SAME_GROUP);
*/
new_blob = make_blob(fi,body, BLNULL);
if_stmt->entry.Template.bl_ptr1 = new_blob;
body->control_parent = if_stmt;
return (if_stmt);
}
void
make_extend(s)
PTR_SYMB s;
{
void execerr(), set_blobs();
PTR_BFND p, past_pred;
PTR_BLOB q;
if ((pred_bfnd==BFNULL) || (pred_bfnd->control_parent==BFNULL)
|| ((pred_bfnd->variant != FOR_NODE) &&
(pred_bfnd->variant != WHILE_NODE))) {
fatalstr("Illegal END DO",(char *)NULL, 259);
}
p = get_bfnd(fi,CONTROL_END, s, LLNULL, LLNULL, LLNULL);
if (is_openmp_stmt) { /*OMP*/
is_openmp_stmt = 0; /*OMP*/
p -> decl_specs = BIT_OPENMP; /*OMP*/
} /*OMP*/
/*change by podd*/
if(thislabel){
thislabel->statbody = p;
thislabel->labtype = LABEXEC;
p->label = thislabel;
}
set_blobs(p, pred_bfnd, SAME_GROUP);
if ((pred_bfnd->variant == PDO_NODE) &&
(pred_bfnd->index == EXTEND_NODE))
{
cur_blob = pred_bfnd->entry.Template.bl_ptr2
= make_blob(fi,BFNULL, BLNULL);
}
else
{
past_pred = pred_bfnd;
pred_bfnd = pred_bfnd->control_parent;
q = follow_blob(pred_bfnd->entry.Template.bl_ptr1);
cur_blob = (q && (q->ref == past_pred)) ?
q : follow_blob(pred_bfnd->entry.Template.bl_ptr2);
}
}
void
make_section_extend()
{
void execerr(), set_blobs();
PTR_BFND p, past_pred, set_stat_list();
PTR_BLOB q;
{
/* mark end of section */
p = get_bfnd(fi,CONTROL_END, SMNULL, LLNULL, LLNULL, LLNULL);
set_stat_list(pred_bfnd, p);
/* mark end of psections's sections */
p = get_bfnd(fi,CONTROL_END, SMNULL, LLNULL, LLNULL, LLNULL);
set_blobs(p, pred_bfnd, SAME_GROUP);
/* prepare for extend statements of psections in case */
if ((pred_bfnd->variant == PSECTIONS_NODE) &&
(pred_bfnd->index == EXTEND_NODE))
{
cur_blob = pred_bfnd->entry.Template.bl_ptr2
= make_blob(fi,BFNULL, BLNULL);
}
else
{
past_pred = pred_bfnd;
pred_bfnd = pred_bfnd->control_parent;
q = follow_blob(pred_bfnd->entry.Template.bl_ptr1);
cur_blob = (q && (q->ref == past_pred)) ?
q : follow_blob(pred_bfnd->entry.Template.bl_ptr2);
}
}
}
void
make_section(section_name, wait_list)
PTR_LLND section_name, wait_list;
{
void execerr(), set_blobs();
PTR_BFND p, set_stat_list();
{
if (pred_bfnd->variant == SECTION_NODE)
{
p = get_bfnd(fi,CONTROL_END, SMNULL, LLNULL, LLNULL, LLNULL);
set_stat_list(pred_bfnd, p);
}
if ((pred_bfnd->variant == PSECTIONS_NODE) ||
(pred_bfnd->variant == PARSECTIONS_NODE))
{
p = get_bfnd(fi,SECTION_NODE, SMNULL, section_name, wait_list, LLNULL);
set_stat_list(pred_bfnd, p);
/* pred_bfnd = p;*/
}
else printf("stat.c:make_section: SECTION NODE's attachment point is not a PSECTION NODE\n");
}
}
/*
* procedure_call gets an id and parameter list.
* It handles procedures not seen yet
*/
PTR_SYMB
procedure_call(entry)
PTR_HASH entry;
{
register PTR_SYMB symb_ptr;
entry = correct_symtab(entry, PROCEDURE_NAME);
for (symb_ptr = entry->id_attr; symb_ptr; symb_ptr = symb_ptr->outer)
if (symb_ptr->variant == PROCEDURE_NAME)
return (symb_ptr);
symb_ptr = get_proc_symbol(entry);
symb_ptr->variant = PROCEDURE_NAME;
symb_ptr->type = global_default;
symb_ptr->entry.proc_decl.seen = NO;
return (symb_ptr);
}
/*
* proceduer match_parameters gets a proc_id and param_list and performs type
* checking
*/
void
match_parameters(proc_id, param_list)
PTR_SYMB proc_id;
PTR_LLND param_list;
{
PTR_LLND new;
void err();
new = make_llnd(fi,FUNC_CALL, param_list, LLNULL, proc_id);
if (proc_id->entry.proc_decl.seen == YES)
if (!chk_params(proc_id->entry.proc_decl.in_list, param_list))
/* err(" Parameter mismatch ")*/ /*podd*/ ;
/*
* if procedure declaration not seen yet and otherwise too add this call to
* the call list
*/
new->entry.proc.next_call = proc_id->entry.proc_decl.call_list;
proc_id->entry.proc_decl.call_list = new;
}
/*
* chk_params checks formals against actuals -- to be added later
*/
int
chk_params(formal, actual)
PTR_SYMB formal;
PTR_LLND actual;
{
return (1);
}
/*
* set_stat_list -- links together an old BIF node list with a new one
*
* input:
* old_list - old BIF node list
* stat - new BIF node
*
* output:
* a BIF node list that links these two together
*/
PTR_BFND
set_stat_list(old_list, stat)
PTR_BFND old_list, stat;
{
PTR_BFND ret=BFNULL;
BOOL start_new_group = NO;
void fatal(), set_blobs(), make_prog_header(), close_groups();
if (!stat) return (old_list);
/* The proper place for this piece of code is in cur_scope(). */
/* if (pred_bfnd->variant == GLOBAL)
make_prog_header(); */
switch (stat->variant) {
case (IF_NODE):
case (LOGIF_NODE):
case (FORALL_STAT):
close_groups();
return (old_list);
/* start of group */
case (INTERFACE_STMT):
case (INTERFACE_OPERATOR):
case (INTERFACE_ASSIGNMENT):
case (STRUCT_DECL):
case (CDOALL_NODE):
case (SDOALL_NODE):
case (DOACROSS_NODE):
case (CDOACROSS_NODE):
case (FOR_NODE):
case (PROCESS_DO_STAT):
case (WHILE_NODE):
case (FORALL_NODE):
case (PARDO_NODE):
case (PROCESSES_STAT):
case (PDO_NODE):
case (PARREGION_NODE):
case (PSECTIONS_NODE):
case (PARSECTIONS_NODE):
case (SECTION_NODE):
case (CRITSECTION_NODE):
case (SINGLEPROCESS_NODE):
case (SWITCH_NODE):
case (WHERE_BLOCK_STMT):
case (OMP_SECTION_DIR): /*OMP*/
case (OMP_PARALLEL_DIR): /*OMP*/
case (OMP_SINGLE_DIR): /*OMP*/
case (OMP_MASTER_DIR): /*OMP*/
case (OMP_CRITICAL_DIR): /*OMP*/
case (OMP_ORDERED_DIR): /*OMP*/
case (OMP_WORKSHARE_DIR): /*OMP*/
case (OMP_PARALLEL_SECTIONS_DIR): /*OMP*/
case (OMP_PARALLEL_WORKSHARE_DIR): /*OMP*/
/* case (ACC_REGION_DIR): */ /*ACC*/
/* case (ACC_DATA_REGION_DIR): */ /*ACC*/
start_new_group = NEW_GROUP1;
/* NO_OP nodes */
case (VAR_DECL):
case (PARAM_DECL):
case (COMM_STAT):
case (NAMELIST_STAT):
case (PROS_COMM):
case (DIM_STAT):
case (HPF_TEMPLATE_STAT):
case (HPF_PROCESSORS_STAT):
case (DVM_DISTRIBUTE_DIR):
case (DVM_ALIGN_DIR):
case (DVM_DYNAMIC_DIR):
case (DVM_SHADOW_DIR):
case (DVM_VAR_DECL):
case (DVM_POINTER_DIR):
case (DVM_HEAP_DIR):
case (DVM_INHERIT_DIR):
case (DVM_TASK_DIR):
case (DVM_REDUCTION_GROUP_DIR):
case (DVM_REMOTE_GROUP_DIR):
case (DVM_INDIRECT_GROUP_DIR):
case (DVM_CONSISTENT_GROUP_DIR):
case (DVM_CONSISTENT_DIR):
case (DVM_ASYNCID_DIR):
case (ACC_ROUTINE_DIR):
added new directives
2024-12-05 12:50:36 +03:00
case (ACC_DECLARE_DIR):
added project
2023-09-14 19:43:13 +03:00
case (DATA_DECL):
case (EXTERN_STAT):
case (INTRIN_STAT):
case (EQUI_STAT):
case (IMPL_DECL):
case (SAVE_DECL):
case (INCLUDE_STAT):
case (ATTR_DECL):
case (INPORT_DECL):
case (OUTPORT_DECL):
case (ALLOCATABLE_STMT):
case (SEQUENCE_STMT):
case (PRIVATE_STMT):
case (PUBLIC_STMT):
case (OPTIONAL_STMT):
case (POINTER_STMT):
case (TARGET_STMT):
case (STATIC_STMT):
/* not an assignment stat */
case (GOTO_NODE):
case (ASSGOTO_NODE):
case (COMGOTO_NODE):
case (ARITHIF_NODE):
case (LOOP_NODE):
case (EXIT_NODE):
case (CONT_STAT):
case (RETURN_STAT):
case (STOP_STAT):
case (PAUSE_NODE):
case (CASE_NODE):
case (DEFAULT_NODE):
/* other */
case (ASSIGN_STAT):
case (STMTFN_STAT):
case (SUM_ACC):
case (MULT_ACC):
case (MAX_ACC):
case (MIN_ACC):
case (CAT_ACC):
case (OR_ACC):
case (AND_ACC):
case (READ_STAT):
case (WRITE_STAT):
case (PRINT_STAT):
case (BACKSPACE_STAT):
case (REWIND_STAT):
case (ENDFILE_STAT):
case (INQUIRE_STAT):
case (OPEN_STAT):
case (CLOSE_STAT):
case (OTHERIO_STAT):
case (FORMAT_STAT):
case (PROC_STAT):
case (PROS_STAT):
case (PROS_STAT_LCTN):
case (PROS_STAT_SUBM):
case (ASSLAB_STAT):
case (LOCK_NODE):
case (UNLOCK_NODE):
case (POST_NODE):
case (WAIT_NODE):
case (CLEAR_NODE):
case (POSTSEQ_NODE):
case (WAITSEQ_NODE):
case (SETSEQ_NODE):
case (PRIVATE_NODE):
case (GUARDS_NODE):
case (CYCLE_STMT):
case (EXIT_STMT):
case (CONTAINS_STMT):
case (WHERE_NODE):
case (USE_STMT):
case (MODULE_PROC_STMT):
case (OVERLOADED_ASSIGN_STAT):
case (POINTER_ASSIGN_STAT):
case (OVERLOADED_PROC_STAT):
case (INTENT_STMT):
case (CHANNEL_STAT):
case (MERGER_STAT):
case (DVM_REDISTRIBUTE_DIR):
case (DVM_PARALLEL_ON_DIR):
case (HPF_INDEPENDENT_DIR):
case (DVM_SHADOW_GROUP_DIR):
case (DVM_SHADOW_START_DIR):
case (DVM_SHADOW_WAIT_DIR):
case (DVM_REDUCTION_START_DIR):
case (DVM_REDUCTION_WAIT_DIR):
case (DVM_CONSISTENT_START_DIR):
case (DVM_CONSISTENT_WAIT_DIR):
case (DVM_REALIGN_DIR):
case (DVM_NEW_VALUE_DIR):
case (DVM_REMOTE_ACCESS_DIR):
case (DVM_TASK_REGION_DIR):
case (DVM_END_TASK_REGION_DIR):
case (DVM_ON_DIR):
case (DVM_END_ON_DIR):
case (DVM_MAP_DIR):
case (DVM_PARALLEL_TASK_DIR):
case (DVM_RESET_DIR):
case (DVM_PREFETCH_DIR):
case (DVM_INDIRECT_ACCESS_DIR):
case (DVM_OWN_DIR):
case (DVM_INTERVAL_DIR):
case (DVM_ENDINTERVAL_DIR):
case (DVM_EXIT_INTERVAL_DIR):
case (DVM_DEBUG_DIR):
case (DVM_ENDDEBUG_DIR):
case (DVM_TRACEON_DIR):
case (DVM_TRACEOFF_DIR):
case (DVM_BARRIER_DIR):
case (DVM_CHECK_DIR):
case (DVM_ASYNCHRONOUS_DIR):
case (DVM_ENDASYNCHRONOUS_DIR):
case (DVM_ASYNCWAIT_DIR):
case (DVM_F90_DIR):
case (DVM_IO_MODE_DIR):
case (DVM_CP_CREATE_DIR):
case (DVM_CP_LOAD_DIR):
case (DVM_CP_SAVE_DIR):
case (DVM_CP_WAIT_DIR):
case (DVM_LOCALIZE_DIR):
case (DVM_SHADOW_ADD_DIR):
case (MOVE_PORT):
case (DVM_TEMPLATE_CREATE_DIR):
case (DVM_TEMPLATE_DELETE_DIR):
case (SEND_STAT):
case (RECEIVE_STAT):
case (ENDCHANNEL_STAT):
case (PROBE_STAT):
case (ALLOCATE_STMT):
case (DEALLOCATE_STMT):
case (NULLIFY_STMT):
case (OMP_DO_DIR): /*OMP*/
case (OMP_END_DO_DIR): /*OMP*/
case (OMP_PARALLEL_DO_DIR): /*OMP*/
case (OMP_END_PARALLEL_DO_DIR): /*OMP*/
case (OMP_BARRIER_DIR): /*OMP*/
case (OMP_ATOMIC_DIR): /*OMP*/
case (OMP_FLUSH_DIR): /*OMP*/
case (OMP_THREADPRIVATE_DIR): /*OMP*/
case (OMP_ONETHREAD_DIR): /*OMP*/
case (ACC_REGION_DIR): /*ACC*/
case (ACC_END_REGION_DIR): /*ACC*/
case (ACC_CHECKSECTION_DIR): /*ACC*/
case (ACC_END_CHECKSECTION_DIR): /*ACC*/
case (ACC_GET_ACTUAL_DIR): /*ACC*/
case (ACC_ACTUAL_DIR): /*ACC*/
case (SPF_ANALYSIS_DIR): /*SPF*/
case (SPF_PARALLEL_DIR): /*SPF*/
case (SPF_TRANSFORM_DIR): /*SPF*/
case (SPF_PARALLEL_REG_DIR): /*SPF*/
case (SPF_END_PARALLEL_REG_DIR): /*SPF*/
case (SPF_CHECKPOINT_DIR): /*SPF*/
if (start_new_group) {
if (stat->variant == CDOALL_NODE
|| stat->variant == SDOALL_NODE
|| stat->variant == DOACROSS_NODE
|| stat->variant == CDOACROSS_NODE)
set_blobs(stat, pred_bfnd, NEW_GROUP2);
else
set_blobs(stat, pred_bfnd, NEW_GROUP1);
} else
set_blobs(stat, pred_bfnd, SAME_GROUP);
break;
case (CONTROL_END):
case (PROCESSES_END):
/* case (ACC_END_REGION_DIR): */ /*ACC*/
case (OMP_END_PARALLEL_DIR): /*OMP*/
case (OMP_END_SINGLE_DIR): /*OMP*/
case (OMP_END_MASTER_DIR): /*OMP*/
case (OMP_END_CRITICAL_DIR): /*OMP*/
case (OMP_END_ORDERED_DIR): /*OMP*/
case (OMP_END_PARALLEL_WORKSHARE_DIR): /*OMP*/
case (OMP_END_WORKSHARE_DIR): /*OMP*/
case (OMP_END_PARALLEL_SECTIONS_DIR): /*OMP*/
case (OMP_END_SECTIONS_DIR): /*OMP*/ {
make_endblock(stat);
break;
}
default:
err("Compiler bug (stat.c)", 0);
ret = old_list;
}
close_groups();
return (ret);
}
void
close_groups()
{
PTR_BFND past_pred;
PTR_BLOB q;
while (end_group > 0) {
past_pred = pred_bfnd;
pred_bfnd = pred_bfnd->control_parent;
q = follow_blob(pred_bfnd->entry.Template.bl_ptr1);
cur_blob = (q && (q->ref == past_pred)) ?
q : follow_blob(pred_bfnd->entry.Template.bl_ptr2);
/* cur_blob = follow_blob(pred_bfnd->entry.Template.bl_ptr1); */
--end_group;
}
}
/*
* Makes a PROG_HEDR statement for programs which does not start with
* a program name.
*/
void
make_prog_header()
{/*never used function*/
PTR_BFND first_bfnd;
/*PTR_BLOB b;*/
void set_blobs();
first_bfnd = BFNULL;
parstate = INSIDE;
set_blobs(first_bfnd, global_bfnd, NEW_GROUP1);
}
PTR_SYMB
proc_decl_init(entry, type)
PTR_HASH entry;
int type;
{
PTR_SYMB symb_ptr;
undeftype = NO;
entry = correct_symtab(entry, type);
mod_offset = yylineno - 1;
for (symb_ptr = head_symb; symb_ptr; symb_ptr = symb_ptr->thread)
if ((strcmp(symb_ptr->ident, entry->ident) == 0) &&
(symb_ptr->variant == PROCEDURE_NAME))
break;
if (!symb_ptr)
symb_ptr = install_entry(entry, SOFT);
if (type == FUNCTION_NAME)
symb_ptr->type = (vartype == global_default) ?
(undeftype ? global_unknown
:impltype[*entry->ident - 'a'])
: vartype;
symb_ptr->variant = type;
symb_ptr->scope = global_bfnd;
symb_ptr->entry.proc_decl.seen = YES;
return (symb_ptr);
}
/*
* End of declaration section of procedure. Allocate storage.
*/
void
enddcl()
{ PTR_BFND scope;
PTR_SYMB fname,res;
parstate = INEXEC;
/*16.03.03*/
scope=cur_scope();
if(scope->variant == FUNC_HEDR && scope->entry.Template.ll_ptr1){ /*current scope is function header with RESULT clause*/
fname = scope->entry.Template.symbol;
res = scope->entry.Template.ll_ptr1->entry.Template.symbol;
fname->type = res->type; /* characteristics of result identifier are set on function name*/
fname->attr =fname->attr | res->attr;
}
/*
docommon();
doequiv();
docomleng();
*/
}
/*
* Start a new procedure
*/
void
newprog()
{
void execerr();
mod_offset = yylineno - 1;
/* if (parstate != OUTSIDE)
execerr("missing end statement", (char *)NULL); */
if (parstate == OUTSIDE) {
setimpl(global_float, 'a', 'z');
setimpl(global_int, 'i', 'n');
}
parstate = INSIDE;
}
/*
* Main program or Block data
*/
void
startproc(prgname, class)
PTR_SYMB prgname;
int class;
{
}
/*
* pop_lab either marks all labels in inner blocks unreachable
* or moves all labels referred to in inner blocks out a level
*/ /*
void
pop_lab()
{
register PTR_LABEL lp;
for (lp = head_label; lp; lp = lp->next)
if (lp->labdefined) {
*/ /* mark all labels in inner blocks unreachable */
/* if (lp->blklevel > blklevel)
lp->labinacc = YES;
} else if (lp->blklevel > blklevel) {
*/ /* move all labels referred to in inner blocks out a level */
/* lp->blklevel = blklevel;
}
}
*/
/*
* make_do handles the DO statement.
*
* input:
* label - the label of the last statement of the DO loop
* spec - list of low level nodes specifying the starting,
* value, end value, and increment of the loop
*
* output:
* returns a BIF node which contains the necessary information
* of a loop header
*/
PTR_BFND
make_do(type, label, symbol, start, end, stride)
int type;
PTR_LABEL label;
PTR_SYMB symbol;
PTR_LLND start, end, stride;
{
PTR_BFND bfnd;
PTR_LLND ddot;
if (symbol != SMNULL)
symbol->dovar = 1;
if(type == FOR_NODE)
ddot = make_llnd(fi, DDOT, start, end, SMNULL);
else
ddot = start;
bfnd = get_bfnd(fi, type, symbol, ddot, stride, LLNULL);
bfnd->entry.for_node.doend = label;
return (bfnd);
}
/* Assuming where_cond is unused in FORTRAN */
PTR_BFND
make_pardo(type, label, symbol, start, end, stride, qualities)
int type;
PTR_LABEL label;
PTR_SYMB symbol;
PTR_LLND start, end, stride, qualities;
{
PTR_BFND bfnd;
PTR_LLND ddot;
ddot = make_llnd(fi, DDOT, start, end, SMNULL);
bfnd = get_bfnd(fi, type, symbol, ddot, stride, LLNULL);
bfnd->entry.for_node.doend = label;
bfnd->entry.for_node.where_cond = qualities;
return (bfnd);
}
PTR_BFND
make_processdo(type, label, symbol, start, end, stride)
int type;
PTR_LABEL label;
PTR_SYMB symbol;
PTR_LLND start, end, stride;
{
PTR_BFND bfnd;
PTR_LLND ddot;
symbol->dovar = 1;
ddot = make_llnd(fi, DDOT, start, end, SMNULL);
bfnd = get_bfnd(fi, type, symbol, ddot, stride, LLNULL);
bfnd->entry.for_node.doend = label;
return (bfnd);
}
PTR_BFND
make_processes()
{
PTR_BFND p;
void make_prog_header();
if (pred_bfnd->variant == GLOBAL)
make_prog_header();
p = get_bfnd(fi, PROCESSES_STAT, SMNULL, LLNULL, LLNULL, LLNULL);
return (p);
}
void
set_blobs(stat, parent, new_group)
PTR_BFND stat, parent;
int new_group;
{
if (((new_group == NEW_GROUP1) && stat->entry.Template.bl_ptr1) ||
((new_group == NEW_GROUP2) && stat->entry.Template.bl_ptr2))
return;
stat->control_parent = parent;
if (!cur_blob) {
/*(void)fprintf(stderr, "cur_blob is null !\n");*/ /*podd*/
fatalstr("Illegal program structure (set_blobs)",(char *)NULL,342);
return;
}
if (cur_blob->ref) {
cur_blob->next = make_blob(fi,stat, BLNULL);
cur_blob = cur_blob->next;
} else
cur_blob->ref = stat;
if (new_group) {
pred_bfnd = stat;
cur_blob = make_blob(fi,BFNULL, BLNULL);
if (new_group == NEW_GROUP1)
stat->entry.Template.bl_ptr1 = cur_blob;
else
stat->entry.Template.bl_ptr2 = cur_blob;
}
}
PTR_LABEL make_label_node(fi, l)
PTR_FILE fi;
long l;
{ PTR_LABEL new_lab;
PTR_BFND this_scope;
this_scope = cur_scope();
for (new_lab = fi->head_lab; new_lab; new_lab = new_lab->next)
if (new_lab->stateno == l && new_lab->scope == this_scope)
return (new_lab);
new_lab =make_label(fi, l);
if(new_lab->stateno == 0)
err("Label out of range",38);
new_lab -> scope = this_scope;
return (new_lab);
}
int is_interface_stat(st)
PTR_BFND st;
{if(st->variant == INTERFACE_STMT || st->variant == INTERFACE_ASSIGNMENT || st->variant == INTERFACE_OPERATOR)
return(1);
else
return(0);
}
PTR_BFND
make_endparallel()
{
PTR_BFND p = get_bfnd(fi,OMP_END_PARALLEL_DIR, SMNULL, LLNULL, LLNULL, LLNULL);
/*PTR_BLOB q;*/
if ((!pred_bfnd) || (pred_bfnd->variant != OMP_PARALLEL_DIR))
execerr("OMP END PARALLEL DIR out of place", (char *)NULL);
return p;
}
PTR_BFND
make_parallel()
{
PTR_BFND p = get_bfnd(fi, OMP_PARALLEL_DIR, SMNULL, LLNULL, LLNULL, LLNULL);
return (p);
}
PTR_BFND
make_endsingle()
{
PTR_BFND p = get_bfnd(fi,OMP_END_SINGLE_DIR, SMNULL, LLNULL, LLNULL, LLNULL);
/*PTR_BLOB q;*/
if ((!pred_bfnd) || (pred_bfnd->variant != OMP_SINGLE_DIR))
execerr("OMP END SINGLE DIR out of place", (char *)NULL);
return p;
}
PTR_BFND
make_single()
{
PTR_BFND p;
p = get_bfnd(fi, OMP_SINGLE_DIR, SMNULL, LLNULL, LLNULL, LLNULL);
return (p);
}
PTR_BFND
make_endmaster()
{
PTR_BFND p = get_bfnd(fi,OMP_END_MASTER_DIR, SMNULL, LLNULL, LLNULL, LLNULL);
if ((!pred_bfnd) || (pred_bfnd->variant != OMP_MASTER_DIR))
execerr("OMP END MASTER DIR out of place", (char *)NULL);
return p;
}
PTR_BFND
make_master()
{
PTR_BFND p = get_bfnd(fi, OMP_MASTER_DIR, SMNULL, LLNULL, LLNULL, LLNULL);
return (p);
}
PTR_BFND
make_endordered()
{
PTR_BFND p = get_bfnd(fi,OMP_END_ORDERED_DIR, SMNULL, LLNULL, LLNULL, LLNULL);
/*PTR_BLOB q;*/
if ((!pred_bfnd) || (pred_bfnd->variant != OMP_ORDERED_DIR))
execerr("OMP END ORDERED DIR out of place", (char *)NULL);
return p;
}
PTR_BFND
make_ordered()
{
PTR_BFND p;
p = get_bfnd(fi, OMP_ORDERED_DIR, SMNULL, LLNULL, LLNULL, LLNULL);
return (p);
}
PTR_BFND
make_endcritical()
{
PTR_BFND p = get_bfnd(fi,OMP_END_CRITICAL_DIR, SMNULL, LLNULL, LLNULL, LLNULL);
if ((!pred_bfnd) || (pred_bfnd->variant != OMP_CRITICAL_DIR))
execerr("OMP END CRITICAL DIR out of place", (char *)NULL);
return p;
}
PTR_BFND
make_critical()
{
PTR_BFND p = get_bfnd(fi, OMP_CRITICAL_DIR, SMNULL, LLNULL, LLNULL, LLNULL);
return (p);
}
PTR_BFND
make_endsections()
{
PTR_BFND p;
/*PTR_BLOB q;*/
/* mark end of section */
p = get_bfnd(fi,CONTROL_END, SMNULL, LLNULL, LLNULL, LLNULL);
set_stat_list(pred_bfnd, p);
if ((!pred_bfnd) || (pred_bfnd->variant != OMP_SECTIONS_DIR)) {
fprintf (stderr,"%d",pred_bfnd->variant);
execerr("OMP END SECTIONS DIR out of place", (char *)NULL);
}
p = get_bfnd(fi,OMP_END_SECTIONS_DIR, SMNULL, LLNULL, LLNULL, LLNULL);
return p;
}
PTR_BFND
make_sections(PTR_LLND clause)
{
PTR_BFND p;
p = get_bfnd(fi, OMP_SECTIONS_DIR, SMNULL, clause, LLNULL, LLNULL);
set_blobs(p, pred_bfnd, NEW_GROUP1);
p = get_bfnd(fi, OMP_SECTION_DIR, SMNULL, LLNULL, LLNULL, LLNULL);
return (p);
}
PTR_BFND
make_ompsection()
{
PTR_BFND p;
/*PTR_BLOB q;*/
if (pred_bfnd) {
if (pred_bfnd->variant == OMP_SECTION_DIR) {
if (last_bfnd->variant == OMP_SECTION_DIR) {
return BFNULL;
} else {
p = get_bfnd(fi,CONTROL_END, SMNULL, LLNULL, LLNULL, LLNULL);
set_stat_list(pred_bfnd, p);
}
}
}
p = get_bfnd(fi, OMP_SECTION_DIR, SMNULL, LLNULL, LLNULL, LLNULL);
return p;
}
PTR_BFND
make_endparallelsections()
{
PTR_BFND p;
/*PTR_BLOB q;*/
/* mark end of section */
p = get_bfnd(fi,CONTROL_END, SMNULL, LLNULL, LLNULL, LLNULL);
set_stat_list(pred_bfnd, p);
if ((!pred_bfnd) || (pred_bfnd->variant != OMP_PARALLEL_SECTIONS_DIR)) {
fprintf (stderr,"%d",pred_bfnd->variant);
execerr("OMP END PARALLEL SECTIONS DIR out of place", (char *)NULL);
}
p = get_bfnd(fi,OMP_END_PARALLEL_SECTIONS_DIR, SMNULL, LLNULL, LLNULL, LLNULL);
return p;
}
PTR_BFND
make_parallelsections(PTR_LLND clause)
{
PTR_BFND p;
p = get_bfnd(fi, OMP_PARALLEL_SECTIONS_DIR, SMNULL, clause, LLNULL, LLNULL);
set_blobs(p, pred_bfnd, NEW_GROUP1);
p = get_bfnd(fi, OMP_SECTION_DIR, SMNULL, LLNULL, LLNULL, LLNULL);
return (p);
}
PTR_BFND
make_endworkshare()
{
PTR_BFND p = get_bfnd(fi,OMP_END_WORKSHARE_DIR, SMNULL, LLNULL, LLNULL, LLNULL);
/*PTR_BLOB q;*/
if ((!pred_bfnd) || (pred_bfnd->variant != OMP_WORKSHARE_DIR))
execerr("OMP END WORKSHARE DIR out of place", (char *)NULL);
return p;
}
PTR_BFND
make_workshare()
{
PTR_BFND p = get_bfnd(fi, OMP_WORKSHARE_DIR, SMNULL, LLNULL, LLNULL, LLNULL);
return (p);
}
PTR_BFND
make_endparallelworkshare()
{
PTR_BFND p = get_bfnd(fi,OMP_END_PARALLEL_WORKSHARE_DIR, SMNULL, LLNULL, LLNULL, LLNULL);
if ((!pred_bfnd) || (pred_bfnd->variant != OMP_PARALLEL_WORKSHARE_DIR))
execerr("OMP END PARALLEL WORKSHARE DIR out of place", (char *)NULL);
return p;
}
PTR_BFND
make_parallelworkshare()
{
PTR_BFND p;
p = get_bfnd(fi, OMP_PARALLEL_WORKSHARE_DIR, SMNULL, LLNULL, LLNULL, LLNULL);
return (p);
}
Reference in New Issue Copy Permalink