Alexander_KS/SAPFOR
4
2
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity
Files
13326020430e2ad5657c93604d3dd4d7703a4729
SAPFOR/dvm/fdvm/trunk/fdvm/io.cpp

2906 lines
97 KiB
C++
Raw Normal View History

added project
2023-09-14 19:43:13 +03:00
/**************************************************************\
* Fortran DVM *
* *
* Input/Output Statements Processing *
\**************************************************************/
#include "dvm.h"
#define NO_ERROR_MSG 0
static const char *filePositionArgsStrings[] = { "unit", "fmt", "rec", "err", "iostat", "end", "nml", "eor", "size", "advance", "iomsg" };
// enum for new open/close
enum {UNIT_IO, ACCESS_IO, ACTION_IO, ASYNC_IO, BLANK_IO, DECIMAL_IO, DELIM_IO, ENCODING_IO, ERR_IO, FILE_IO,
FORM_IO, IOSTAT_IO, IOMSG_IO, NEWUNIT_IO, PAD_IO, POSITION_IO, RECL_IO, ROUND_IO, SIGN_IO, STATUS_IO, DVM_MODE_IO, NUMB__CL };
static const char *openCloseArgStrings[] = { "unit", "access", "action", "async", "blank", "decimal", "delim",
"encoding", "err", "file", "form", "iostat", "iomsg", "newunit", "pad", "position", "recl", "round", "sign",
"status", "io_mode" };
enum { UNIT_RW, FMT_RW, NML_RW, ADVANCE_RW, ASYNC_RW, BLANK_RW, DECIMAL_RW, DELIM_RW, END_RW, EOR_RW, ERR_RW, ID_RW,
IOMSG_RW, IOSTAT_RW, PAD_RW, POS_RW, REC_RW, ROUND_RW, SIGN_RW, SIZE_RW, NUMB__RW };
static const char *readWriteArgStrings[] = { "unit", "fmt", "nml", "advance", "async", "blank", "decimal", "delim", "end", "eor", "err", "id", "iomsg", "iostat", "pad", "pos", "rec", "round", "sign", "size"};
int Check_ReadWritePrint(SgExpression *ioc[], SgStatement *stmt, int error_msg);
void Replace_ReadWritePrint( SgExpression *ioc[], SgStatement *stmt);
int TestIOList(SgExpression *iol, SgStatement *stmt, int error_msg)
{SgExpression *el,*e;
int tst=1;
for (el=iol;el;el=el->rhs()) {
e = el->lhs(); // list item
ReplaceFuncCall(e);
if(isSgExprListExp(e)) // implicit loop in output list
e = e->lhs();
if(isSgIOAccessExp(e)) {
tst=ImplicitLoopTest(e,stmt,error_msg) ? tst : 0;
}
else
tst=IOitemTest(e,stmt,error_msg) ? tst : 0;
}
return (tst);
}
int ImplicitLoopTest(SgExpression *eim, SgStatement *stmt, int error_msg)
{int tst =1;
SgExpression *ell, *e;
if(isSgExprListExp(eim->lhs()))
for (ell = eim->lhs();ell;ell=ell->rhs()){ //looking through item list of implicit loop
e = ell->lhs();
if(isSgExprListExp(e)) // implicit loop in output list
e = e->lhs();
if(isSgIOAccessExp(e)){
tst=ImplicitLoopTest(e,stmt,error_msg) ? tst : 0;
}
else
tst=IOitemTest(e,stmt,error_msg) ? tst : 0;
}
else
tst=IOitemTest(eim->lhs(),stmt,error_msg) ? tst : 0;
return(tst);
}
int IOitemTest(SgExpression *e, SgStatement *stmt, int error_msg)
{int tst=1;
if(!e) return(1);
if(isSgArrayRefExp(e)){
if( HEADER(e->symbol())) {
if(error_msg)
Error("Illegal I/O list item: %s",e->symbol()->identifier(),192,stmt);
return (0);
} else
return(1);
}
if(isSgRecordRefExp(e)) {
SgExpression *eleft = SearchDistArrayField(e); //from right to left
if(eleft) {
if(error_msg)
Error("Illegal I/O list item: %s",isSgRecordRefExp(eleft) ? eleft->rhs()->symbol()->identifier(): eleft->symbol()->identifier(),192,stmt);
return (0);
} else
return(1);
}
if(e->variant() == ARRAY_OP) //substring
return(IOitemTest(e->lhs(),stmt,error_msg));
if(isSgVarRefExp(e) || isSgValueExp(e))
return(1);
tst=IOitemTest(e->lhs(),stmt,error_msg) ? tst : 0;
tst=IOitemTest(e->rhs(),stmt,error_msg) ? tst : 0;
return(tst);
}
SgStatement *Any_IO_Statement(SgStatement *stmt)
{ SgStatement *last;
ReplaceContext(stmt);
if(!IN_COMPUTE_REGION)
LINE_NUMBER_BEFORE(stmt,stmt);
SgExpression *ioEnd[3];
if(hasEndErrControlSpecifier(stmt, ioEnd))
ReplaceStatementWithEndErrSpecifier(stmt,ioEnd);
if(perf_analysis){
InsertNewStatementBefore(St_Biof(),stmt);
InsertNewStatementAfter ((last = St_Eiof()),stmt,stmt->controlParent());
cur_st = stmt;
return(last);
}
return(stmt);
}
void IoModeDirective(SgStatement *stmt, char io_modes_str[], int error_msg)
{
SgExprListExp *modes = isSgExprListExp(stmt->expr(0));
int imode = 0;
if (!options.isOn(IO_RTS)) {
if(error_msg)
warn("Directive IO_MODE is ignored, -ioRTS option should be specified",623,stmt);
return;
}
for (imode = 0; imode < modes->length(); ++imode) {
SgExpression *mode = modes->elem(imode);
if (mode->variant() == PARALLEL_OP)
io_modes_str[imode] = 'p';
else if (mode->variant() == ACC_LOCAL_OP)
io_modes_str[imode] = 'l';
else if (mode->variant() == ACC_ASYNC_OP)
io_modes_str[imode] = 's';
else
if(error_msg)
err("Illegal elements in IO_MODE directive", 460, stmt);
}
io_modes_str[imode] = '\0';
if (stmt->lexNext()->variant() != OPEN_STAT) {
if(error_msg)
err("Misplaced directive: no OPEN statement after IO_MODE statement", 103, stmt);
io_modes_str[0]='\0';
}
}
void Open_Statement(SgStatement *stmt, char io_modes_str[], int error_msg)
{
Any_IO_Statement(stmt);
if(options.isOn(IO_RTS) && io_modes_str[0] != '\0')
Open_RTS(stmt, io_modes_str, error_msg);
else
OpenClose(stmt,error_msg);
}
void Open_RTS(SgStatement* stmt, char* io_modes_str, int error_msg) {
SgExpression *ioc[40];
int io_err = control_list_open_new(stmt->expr(1), ioc);
if(!io_err)
{
if( error_msg )
err("Illegal elements in control list", 185, stmt);
return;
}
bool suitableForNewIO = checkArgsOpen(ioc, stmt, error_msg, io_modes_str);
if (!suitableForNewIO) return;
Dvmh_Open(ioc, io_modes_str);
io_modes_str[0]='\0';
}
void Close_Statement(SgStatement *stmt, int error_msg)
{
Any_IO_Statement(stmt);
if(options.isOn(IO_RTS))
Close_RTS(stmt,error_msg);
else
OpenClose(stmt,error_msg);
}
void Close_RTS(SgStatement *stmt, int error_msg)
{
SgExpression *ioc[NUMB__CL];
int io_err = control_list_close_new(stmt->expr(1), ioc);
if(!io_err)
{
if( error_msg )
{
if (!ioc[UNIT_IO])
err("UNIT not specified in close statement", 456, stmt);
else
err("Illegal elements in control list", 185, stmt);
}
return;
}
bool suitableForNewIO = checkArgsClose(ioc, stmt, error_msg);
// generate If construct:
// if (dvmh_ftn_connected (args) then <by_RTS2> else <BY_IO_Fortran> endif
SgStatement *ifst = IfConnected(stmt,ioc[UNIT_],suitableForNewIO);
SgStatement *last = ifst->lastNodeOfStmt(); //stmt->lexNext();
//true body
Dvmh_Close(ioc);
//false body
NewOpenClose(stmt);
cur_st = last;
}
void OpenClose(SgStatement *stmt, int error_msg)
{
SgExpression *ioc[NUM__O];
int io_err=control_list_open(stmt->expr(1),ioc); // control_list analisys
if(error_msg)
Check_Control_IO_Statement(io_err,ioc,stmt,error_msg);
if(!options.isOn(READ_ALL))
Replace_IO_Statement(ioc,stmt);
cur_st = stmt;
return;
}
void NewOpenClose(SgStatement *stmt)
{
SgExpression *ioc[NUM__O];
int io_err=control_list_open(stmt->expr(1),ioc); // control_list analisys
io_err = Check_Control_IO_Statement(io_err,ioc,stmt,NO_ERROR_MSG);
if(io_err)
ReplaceByStop(io_err,stmt);
else
Replace_IO_Statement(ioc,stmt);
return;
}
void Replace_IO_Statement(SgExpression *ioc[],SgStatement *stmt)
{
cur_st = stmt;
if(ioc[IOSTAT_]) // there is keyed argument IOSTAT
InsertSendIOSTAT(ioc[IOSTAT_]);
ReplaceByIfStmt(stmt);
}
void ReplaceByStop(int io_err, SgStatement *stmt)
{
SgStatement *new_stmt = new SgStatement(STOP_STAT);
stmt->insertStmtAfter(*new_stmt,*stmt->controlParent());
char num3s[4];
format_num(io_err, num3s);
char *buff = new char[strlen(stmt->fileName()) + 75];
sprintf(buff, "Illegal IO statement, error %s on line %d of %s", num3s,stmt->lineNumber(), stmt->fileName());
new_stmt = new SgStatement(PRINT_STAT);
new_stmt->setExpression(0,*new SgExprListExp(*new SgValueExp(buff)));
SgExpression *ecl = new SgExpression(SPEC_PAIR,new SgKeywordValExp("fmt"),new SgKeywordValExp("*"),NULL);
new_stmt->setExpression(1,*new SgExprListExp(*ecl));
stmt->insertStmtAfter(*new_stmt,*stmt->controlParent());
stmt-> extractStmt(); //extract IO statement
return;
}
int Check_Control_IO_Statement(int io_err, SgExpression *ioc[], SgStatement *stmt, int error_msg)
{
if( !io_err )
{
if( error_msg )
err("Illegal elements in control list", 185,stmt);
else
return (185);
}
if( ioc[ERR_] )
{
if( error_msg )
err("END= and ERR= specifiers are illegal in FDVM", 186,stmt);
else
return (186);
}
if( inparloop && (ioc[IOSTAT_] || stmt->variant() == INQUIRE_STAT) || stmt->variant() == READ_STAT) //(stmt->variant() == INQUIRE_STAT && ? (SgExpression *) 1 : ioc[IOSTAT_]) && inparloop )
{
if( error_msg)
err("Illegal I/O statement in the range of parallel loop/region", 184,stmt);
else
return (184);
}
return(0);
}
void Inquiry_Statement(SgStatement *stmt, int error_msg)
{
Any_IO_Statement(stmt);
if(options.isOn(IO_RTS))
; // Inquiry_RTS(stmt);
else
Inquiry(stmt,error_msg);
}
void Inquiry(SgStatement *stmt, int error_msg)
{
SgExpression *ioc[NUM__O+1];
int io_err;
io_err=control_list_inquire(stmt->expr(1),ioc); // control list analysis
if(error_msg)
Check_Control_IO_Statement(io_err,ioc,stmt,error_msg);
cur_st = stmt;
InsertSendInquire(ioc);
ReplaceByIfStmt(stmt);
cur_st = stmt;
}
void FilePosition_Statement(SgStatement *stmt, int error_msg)
{
Any_IO_Statement(stmt);
// RTS BACKSPACE isn't implemented!
if(options.isOn(IO_RTS))
FilePosition_RTS(stmt, error_msg);
else
FilePosition(stmt,error_msg);
}
void FilePosition_RTS(SgStatement* stmt, int error_msg) {
SgExpression *ioc[NUM__R];
int io_err = control_list1(stmt->expr(1), ioc);
// FIXME: it would be better to replace this error to control_list1
if (!ioc[UNIT_]) {
if (error_msg)
err("Unit argument not specified in IO-statement", 456, stmt);
return;
}
if(!io_err)
{
if( error_msg )
err("Illegal elements in control list", 185, stmt);
return;
}
bool suitableForNewIO = checkArgsEnfileRewind(ioc, stmt, error_msg);
// generate If construct:
// if (dvmh_ftn_connected (args) then <by_RTS2> else <BY_IO_Fortran> endif
SgStatement *ifst = IfConnected(stmt,ioc[UNIT_],suitableForNewIO);
SgStatement *last = ifst->lastNodeOfStmt(); //stmt->lexNext();
//true body
Dvmh_FilePosition(ioc, stmt->variant());
//false body
NewFilePosition(stmt); //Replace_IO_Statement(ioc,stmt);
cur_st = last;
}
void FilePosition(SgStatement *stmt, int error_msg)
{
SgExpression *ioc[NUM__R];
int io_err;
io_err = control_list1(stmt->expr(1),ioc); // control_list analisys
if(error_msg)
Check_Control_IO_Statement(io_err,ioc,stmt,error_msg);
Replace_IO_Statement(ioc,stmt);
cur_st = stmt;
return;
}
void NewFilePosition(SgStatement *stmt)
{
SgExpression *ioc[NUM__R];
int io_err = control_list1(stmt->expr(1),ioc); // control_list analisys
io_err = Check_Control_IO_Statement(io_err,ioc,stmt,NO_ERROR_MSG);
if(io_err)
ReplaceByStop(io_err,stmt);
else
Replace_IO_Statement(ioc,stmt);
return;
}
void ReadWrite_Statement(SgStatement *stmt, int error_msg)
{
Any_IO_Statement(stmt);
if(options.isOn(IO_RTS))
ReadWrite_RTS(stmt,error_msg);
else
ReadWritePrint_Statement(stmt,error_msg);
}
void NewReadWritePrint_Statement(SgStatement *stmt)
{
SgExpression *ioc[NUM__R];
int io_err= IOcontrol(stmt->expr(1),ioc,stmt->variant()); //control_list1(stmt->expr(1),ioc); // control_list analisys
io_err = Check_Control_IO_Statement(io_err,ioc,stmt,NO_ERROR_MSG);
if(!io_err)
io_err = Check_ReadWritePrint(ioc,stmt,NO_ERROR_MSG);
if(io_err)
ReplaceByStop(io_err,stmt);
else
Replace_ReadWritePrint(ioc, stmt);
return;
}
void ReadWrite_RTS(SgStatement *stmt, int error_msg)
{
SgExpression *ioc[NUMB__RW];
int io_err = control_list_rw(stmt->expr(1),ioc);
if(!io_err)
{
if( error_msg ) {
if (!ioc[UNIT_RW])
err("UNIT not specified in read/write statement", 456, stmt);
else
err("Illegal elements in control list", 185, stmt);
}
return;
}
bool suitableForNewIO = checkArgsRW(ioc, stmt, error_msg);
// generate If construct:
// if (dvmh_ftn_connected (args) then <by_RTS2> else <BY_IO_Fortran> endif
SgStatement *ifst = IfConnected(stmt,ioc[UNIT_],suitableForNewIO);
SgStatement *last = ifst->lastNodeOfStmt(); //stmt->lexNext();
//true body
Dvmh_ReadWrite(ioc, stmt);
//false body
NewReadWritePrint_Statement(stmt);
cur_st = last;
}
int FixError(const char *str, int ierr, SgSymbol *s, SgStatement *stmt, int error_msg)
{
if(error_msg) {
if(s)
Error(str,s->identifier(),ierr,stmt);
else
err(str,ierr,stmt);
return (-1);
}
else
return(ierr);
}
int Check_ReadWritePrint(SgExpression *ioc[], SgStatement *stmt, int error_msg)
{
if(ioc[END_] || ioc[ERR_] || ioc[EOR_])
return FixError("END=, EOR= and ERR= specifiers are illegal in FDVM",186,NULL,stmt,error_msg);
if(ioc[UNIT_] && (ioc[UNIT_]->type()->variant() == T_STRING) && ioc[UNIT_]->symbol() && HEADER(ioc[UNIT_]->symbol()))
return FixError("'%s' is distributed array",148,ioc[UNIT_]->symbol(),stmt,error_msg);
if(ioc[FMT_])
{
SgKeywordValExp *kwe = isSgKeywordValExp(ioc[FMT_]);
if(kwe && strcmp(kwe->value(),"*"))
return FixError("Invalid format specification",189,NULL,stmt,error_msg);
}
SgExpression *iol = stmt->expr(0); // I/O list
SgExpression *e;
if(iol && (e = isSgArrayRefExp(iol->lhs())) && (HEADER(iol->lhs()->symbol())))
{ // first item is distributed array refference
if (iol->rhs() ) // there are other items in I/O-list
return FixError("Illegal I/O list ",190,NULL,stmt,error_msg);
//if(ioc[IOSTAT_] )
// return FixError("IOSTAT= specifier is illegal in I/O of distributed array", 187,NULL,stmt,error_msg);
if(ioc[FMT_] && !isSgKeywordValExp(ioc[FMT_]) || ioc[NML_] )
return FixError("I/O of distributed array controlled by format specification or NAMELIST is not supported in FDVM", 191,NULL,stmt,error_msg);
if(ioc[UNIT_] && (ioc[UNIT_]->type()->variant() == T_STRING) && ioc[UNIT_]->symbol()) //I/O to internal file
return FixError("'%s' is distributed array",148,e->symbol(),stmt,error_msg);
if(IN_COMPUTE_REGION && !inparloop && !in_checksection )
return FixError("Illegal statement in the range of region (not implemented yet)", 576,NULL,stmt,error_msg);
}
else {
if( iol && !TestIOList(iol,stmt,error_msg) && !error_msg) // check I/O list
return (192);
}
return(0);
}
void Replace_ReadWritePrint( SgExpression *ioc[], SgStatement *stmt)
// READ, WRITE, PRINT statements
{
SgExpression *e, *iol;
int IOtype;
cur_st = stmt;
// analizes UNIT specifier
if(ioc[UNIT_] && (ioc[UNIT_]->type()->variant() == T_STRING)) {
SgKeywordValExp *kwe;
if((kwe=isSgKeywordValExp(ioc[UNIT_])) && (!strcmp(kwe->value(),"*")))
//"*" - system unit
;
else // I/O to internal file
return;
}
// analizes format specifier and determines type of I/O
if(ioc[FMT_]) {
SgKeywordValExp *kwe = isSgKeywordValExp(ioc[FMT_]);
if(kwe) // Format
if(!strcmp(kwe->value(),"*"))
IOtype = 1; // formatted IO, controlled by IO-list
else
return; // illegal format specifier ??
else
IOtype = 2; // formatted IO, controlled by format
// specification or NAMELIST
}
else
IOtype = 3; // unformatted IO
if(ioc[NML_])
IOtype = 2; // formatted IO, controlled by NAMELIST
//looking through the IO-list
iol = stmt->expr(0);
if(!iol) { // input list is absent
Replace_IO_Statement(ioc,stmt);
return;
}
if((e = isSgArrayRefExp(iol->lhs())) && (HEADER(iol->lhs()->symbol()))) {
// first item is distributed array refference
if (iol->rhs()) // error: there are other items in I/O-list
return;
if(!e->lhs() && IOtype != 2) //whole array and format=* or unformatted
{
if (ioc[IOSTAT_]) // there is keyed argument IOSTAT
InsertSendIOSTAT(ioc[IOSTAT_]);
IO_ThroughBuffer(e->symbol(),stmt,ioc[IOSTAT_]);
}
else
return; //error
}
else { // replicated variable list
if(!TestIOList(iol,stmt,NO_ERROR_MSG))
return;
if (ioc[IOSTAT_] || (stmt->variant() == READ_STAT)) {
if(stmt->variant() == READ_STAT)
InsertSendInputList(iol,ioc[IOSTAT_],stmt);
else
InsertSendIOSTAT(ioc[IOSTAT_]);
}
ReplaceByIfStmt(stmt);
}
}
void ReadWritePrint_Statement(SgStatement *stmt, int error_msg)
// READ, WRITE, PRINT statements
{ SgSymbol *sio;
SgExpression *e,*iol;
SgExpression *ioc[NUM__R];
int IOtype, io_err;
cur_st = stmt;
send = 0;
// analizes IO control list and sets on ioc[]
e = stmt->expr(1); // IO control
io_err = IOcontrol(e,ioc,stmt->variant());
if(!io_err && error_msg){
err("Illegal elements in control list", 185,stmt);
return;
}
if((ioc[END_] || ioc[ERR_] || ioc[EOR_]) && error_msg) {
err("END=, EOR= and ERR= specifiers are illegal in FDVM", 186,stmt);
return;
}
if(ioc[UNIT_] && (ioc[UNIT_]->type()->variant() == T_STRING)) {
SgKeywordValExp *kwe;
if((kwe=isSgKeywordValExp(ioc[UNIT_])) && (!strcmp(kwe->value(),"*")))
//"*" - system unit
;
else { // I/O to internal file
if(ioc[UNIT_]->symbol() && HEADER(ioc[UNIT_]->symbol()) && error_msg)
Error("'%s' is distributed array", ioc[UNIT_]->symbol()->identifier(), 148,stmt);
if(error_msg)
TestIOList(stmt->expr(0),stmt,error_msg);
//err("I/O to internal file is not supported in FDVM", stmt);
return;
}
}
// analizes format specifier and determines type of I/O
if(ioc[FMT_]) {
SgKeywordValExp * kwe;
kwe = isSgKeywordValExp(ioc[FMT_]);
if(kwe) // Format
if(!strcmp(kwe->value(),"*"))
IOtype = 1; // formatted IO, controlled by IO-list
else {
IOtype = 0; // illegal format specifier ??
if(error_msg)
err("Invalid format specification", 189,stmt);
return;
}
else
IOtype = 2; // formatted IO, controlled by format
// specification or NAMELIST
}
else
IOtype = 3; // unformatted IO
if(ioc[NML_])
IOtype = 2; // formatted IO, controlled by NAMELIST
//Any_IO_Statement(stmt);
//looking through the IO-list
iol = stmt->expr(0);
if(!iol) { // input list is absent
if(stmt->variant() != READ_STAT || !options.isOn(READ_ALL))
Replace_IO_Statement(ioc,stmt);
return;
}
if((e = isSgArrayRefExp(iol->lhs())) && (HEADER(iol->lhs()->symbol()))) {
// first item is distributed array refference
if (iol->rhs() && error_msg) {// there are other items in I/O-list
err("Illegal I/O list ", 190,stmt);
return;
}
//if(ioc[IOSTAT_] && error_msg) {
// err("IOSTAT= specifier is illegal in I/O of distributed array", 187,stmt);
// return;
// }
if(!e->lhs()) //whole array
if(IOtype != 2) {
sio = e->symbol();
//buf_use[TypeIndex(sio->type()->baseType())] = 1;
if (ioc[IOSTAT_]) // there is keyed argument IOSTAT
InsertSendIOSTAT(ioc[IOSTAT_]);
IO_ThroughBuffer(sio,stmt,ioc[IOSTAT_]);
if(IN_COMPUTE_REGION && !inparloop && !in_checksection && error_msg)
err("Illegal statement in the range of region (not implemented yet)", 576,stmt);
}
else {
if( error_msg)
err("I/O of distributed array controlled by format specification or NAMELIST is not supported in FDVM", 191,stmt);
// illegal format specifier for I/O of distributed array
return;
}
else {
if(error_msg)
err("Illegal I/O list item", 192,stmt);
return;
}
}
else { // replicated variable list
if(!TestIOList(iol,stmt,error_msg))
return;
if (stmt->variant() == READ_STAT) {
if(!options.isOn(READ_ALL))
InsertSendInputList(iol,ioc[IOSTAT_],stmt);
}
else if(ioc[IOSTAT_] )
InsertSendIOSTAT(ioc[IOSTAT_]);
if(stmt->variant() != READ_STAT || !options.isOn(READ_ALL))
ReplaceByIfStmt(stmt);
//if(IN_COMPUTE_REGION && !in_checksection)
// ChangeDistArrayRef(iol);
}
if(inparloop && (send || IN_COMPUTE_REGION) && error_msg)
err("Illegal I/O statement in the range of parallel loop/region", 184,stmt);
}
void IO_ThroughBuffer(SgSymbol *ar, SgStatement *stmt, SgExpression *eiostat)
{
SgStatement *dost=NULL, *contst, *ifst, *next;
SgExpression *esize,*econd,*iodo, *iolist,*ubound,*are,*d, *eN[8];
SgValueExp c1(1),c0(0);
SgLabel *loop_lab=NULL;
//SgSymbol *sio;
int i,l,rank,s,s0,N[8],itype,imem;
int m = -1;
int init,last,step;
int M=0;
cur_st = stmt;
next = stmt->lexNext();
contst = NULL;
imem=ndvm;
ReplaceContext(stmt);
itype = TypeIndex(ar->type()->baseType());
if(itype == -1) //may be derived type
{
Error("Illegal type's array in input-output statement: %s",ar->identifier(),999,stmt);
return;
} else
buf_use[itype] = 1;
l = rank = Rank(ar);
s = IOBufSize; //SIZE_IO_BUF;
for(i=1; i<=rank; i++) {
//calculating size of i-th dimension
esize = ReplaceParameter(ArrayDimSize(ar, i));
eN[i] = NULL;
if(esize && esize->variant()==STAR_RANGE)
{
Error("Assumed-size array: %s",ar->identifier(),162,stmt);
return;
}
if(esize->isInteger())
N[i] = esize->valueInteger();
else
{N[i] = -1; eN[i] = esize;} //!! dummy argument
if((N[i] <= 0) && !eN[i])
{
Error("Array shape declaration error: '%s'", ar->identifier(),193, stmt);
return;
}
}
// calculating s
for(i=1; i<=rank; i++) {
if(eN[i]) {
l=i-1;
break;
}
s0 = s / N[i];
if(!s0) { // s0 == 0
l = i-1;
break;
}
else
s = s0;
}
if(l==rank) { // generating assign statement: m = 1
// m = ndvm;
//doAssignStmtBefore(&c1.copy(),stmt);
M=1;
}
else
m = ndvm++;
if(l+1 <= rank) {
// generating DO statement: DO label idvm01 = 0, N[l+1]-1, s
loop_lab = GetLabel();
contst = new SgStatement(CONT_STAT);
esize = eN[l+1] ? &(eN[l+1]->copy() - c1.copy()) : new SgValueExp(N[l+1]-1);
dost= new SgForStmt(*loop_var[1], c0.copy(), *esize, *new SgValueExp(s), *contst);
BIF_LABEL_USE(dost->thebif) = loop_lab->thelabel;
(dost->lexNext())->setLabel(*loop_lab);
if(l+2 <= rank)
// generating DO nest:
// DO label idvm02 = 0, N[rank]-1
// DO label idvm03 = 0, N[rank-1]-1
// . . .
// DO label idvm0j = 0, N[l+2]-1
//for(i=rank; i>l+1; i--) { //27.11.09
for(i=l+2; i<=rank; i++) {
esize = eN[i] ? &(eN[i]->copy() - c1.copy()) : new SgValueExp(N[i]-1);
dost= new SgForStmt(*loop_var[rank-i+2], c0.copy(), *esize, *dost);
BIF_LABEL_USE(dost->thebif) = loop_lab->thelabel;
}
cur_st->insertStmtAfter(*dost);
for(i=l+1; i<=rank; i++)
contst->lexNext()->extractStmt(); // extracting ENDDO
if((N[l+1]<0) || (N[l+1]-(N[l+1]/s)*s)) {
// generating the construction
// IF (Il+1 + s .LE. Nl+1) THEN
// m = s
// ELSE
// m = Nl+1 - Il+1
// ENDIF
// and then insert it before CONTINUE statement
esize = eN[l+1] ? &(eN[l+1]->copy()) : new SgValueExp(N[l+1]);
econd = & (( *new SgVarRefExp(*loop_var[1]) + *new SgValueExp(s)) <= *esize);
ifst = new SgIfStmt(*econd, *new SgAssignStmt(*DVM000(m),*new SgValueExp(s)), *new SgAssignStmt(*DVM000(m),*esize - *new SgVarRefExp(*loop_var[1])));
contst -> insertStmtBefore(*ifst);
}
else
//dost->insertStmtBefore(*new SgAssignStmt(*DVM000(m),*new SgValueExp(s)));
M=s;
//cur_st = ifst;
stmt->extractStmt();
contst -> insertStmtBefore(*stmt);
// transfering label over D0-statements
BIF_LABEL(dost->thebif) = BIF_LABEL(stmt->thebif);
BIF_LABEL(stmt->thebif) = NULL;
//cur_st = stmt;
}
// creating implicit loop as element of I/O list:
// (BUF(I0), I0= 1,N1*...*Nl*m)
ubound = DVM000(m);
N[0] = 1;
for(i=1; i<=l; i++)
N[0] = N[0] * N[i];
if(M) // M= const
ubound = new SgValueExp(N[0]*M);
else {
ubound = DVM000(m);
if(N[0] != 1)
ubound = &( *ubound * (*new SgValueExp(N[0])) );
}
// ubound = &( *ubound * (*new SgValueExp(N[0])));
// iodo = new SgExpression(DDOT,&c1.copy(), ubound,NULL);
iodo = & SgDDotOp(c1.copy(),*ubound);
iodo = new SgExpression(SEQ,iodo,NULL,NULL);
iodo = new SgExpression(IOACCESS,NULL,iodo,loop_var[0]);
// iodo = new SgIOAccessExp(*loop_var[0], c1.copy(), *ubound);//Sage error
iodo -> setLhs(new SgArrayRefExp(*bufIO[itype], *new SgVarRefExp(*loop_var[0])));
iolist = new SgExprListExp(*iodo);
// iolist -> setLhs(iodo);
// replacing I/O list in source I/O statement
stmt -> setExpression(0,*iolist);
//generating assign statement
//dvm000(i) = ArrCpy(...)
are = new SgArrayRefExp(*bufIO[Integer],c1.copy()); //!!! itype=>Integer (bufIO[itype])
init = ndvm;
//if(l+2 <= rank)
for(i=2; i<(rank-l+1);i++ )
doAssignStmtBefore(new SgVarRefExp(*loop_var[i]),stmt);
if(l+1 <= rank)
doAssignStmtBefore(new SgVarRefExp(*loop_var[1]),stmt);
for(i=l; i; i-- )
doAssignStmtBefore(new SgValueExp(-1),stmt);
last = ndvm;
//if(l+2 <= rank)
for(i=2; i<(rank-l+1);i++ )
doAssignStmtBefore(new SgVarRefExp(*loop_var[i]),stmt);
if(l+1 <= rank) {
d = new SgVarRefExp(*loop_var[1]);
if(M != 1)
d = (M)? &(*d+(*new SgValueExp(M-1))) : &(*d+(*DVM000(m))-c1.copy());
doAssignStmtBefore(d,stmt);
}
step = last+rank;
if(l+1 <= rank) {
ndvm = step + rank - l - 1;
doAssignStmtBefore(&c1.copy(),stmt);
}
ndvm = step+rank;
if(stmt->variant() == READ_STAT){
doAssignStmtAfter (A_CopyTo_DA(are,HeaderRef(ar),init,last,step,2));
if(dvm_debug) {
if(contst)
cur_st = contst;
cur_st->insertStmtAfter(*D_Read(GetAddresDVM(HeaderRefInd(ar,1))));
}
} else
doAssignStmtBefore(DA_CopyTo_A(HeaderRef(ar),are,init,last,step,2),stmt);
// replace I/O statement by: IF(TstIO().NE.0) I/O-statement
ReplaceByIfStmt(stmt);
if(eiostat && dost)
{
LogIf_to_IfThen(stmt->controlParent());
SgLabel *lab_out = GetLabel();
doIfIOSTAT(eiostat,stmt,new SgGotoStmt(*lab_out));
next->setLabel(*lab_out); //next -> send of IOSTAT
}
//calculating maximal number of used loop variables for I/O
nio = (nio < (rank-l+1)) ? (rank-l+1) : nio;
SET_DVM(imem);
}
int IOcontrol(SgExpression *e, SgExpression *ioc[],int type)
// analizes IO_control list (e) and sets on ioc[]
{ SgKeywordValExp *kwe;
SgExpression *ee,*el;
int i;
for(i=NUM__R; i; i--)
ioc[i-1] = NULL;
if(e->variant() == SPEC_PAIR) {
if(type == PRINT_STAT)
ioc[FMT_] = e->rhs();
else {
// ioc[UNIT_] = e->rhs();
kwe = isSgKeywordValExp(e->lhs());
if(!kwe)
return(0);
if (!strcmp(kwe->value(),"unit"))
ioc[UNIT_] = e->rhs();
else if (!strcmp(kwe->value(),"fmt"))
ioc[FMT_] = e->rhs();
else
return(0);
}
return(1);
}
if(e->variant() == EXPR_LIST){
for(el=e; el; el = el->rhs()) {
ee = el->lhs();
if(ee->variant() != SPEC_PAIR)
return(0); // IO_control list error
kwe = isSgKeywordValExp(ee->lhs());
if(!kwe)
return(0);
if (!strcmp(kwe->value(),"unit"))
ioc[UNIT_] = ee->rhs();
else if (!strcmp(kwe->value(),"fmt"))
ioc[FMT_] = ee->rhs();
else if (!strcmp(kwe->value(),"nml"))
ioc[NML_] = ee->rhs();
else if (!strcmp(kwe->value(),"rec"))
ioc[REC_] = ee->rhs();
else if (!strcmp(kwe->value(),"iostat"))
ioc[IOSTAT_] = ee->rhs();
else if (!strcmp(kwe->value(),"end"))
ioc[END_] = ee->rhs();
else if (!strcmp(kwe->value(),"err"))
ioc[ERR_] = ee->rhs();
else if (!strcmp(kwe->value(),"eor"))
ioc[EOR_] = ee->rhs();
else if (!strcmp(kwe->value(),"size"))
ioc[SIZE_] = ee->rhs();
else if (!strcmp(kwe->value(),"advance"))
ioc[ADVANCE_] = ee->rhs();
else if (!strcmp(kwe->value(),"pos"))
ioc[POS_] = ee->rhs();
else
return(0);
}
return(1);
}
else
return(0);
}
int control_list_rw(SgExpression *e, SgExpression *ioc[])
// analizes IO_control list (e) and sets on ioc[]
{ SgKeywordValExp *kwe;
SgExpression *ee,*el;
int i;
for(i=NUMB__RW; i; i--)
ioc[i-1] = NULL;
if(e->variant() == SPEC_PAIR) {
kwe = isSgKeywordValExp(e->lhs());
if (!kwe)
return(0);
if (!strcmp(kwe->value(),"unit"))
ioc[UNIT_RW] = e->rhs();
else if (!strcmp(kwe->value(),"fmt"))
ioc[FMT_RW] = e->rhs();
else if (!strcmp(kwe->value(), "nml"))
ioc[NML_RW] = e->rhs();
else
return(0);
return(1);
}
if(e->variant() == EXPR_LIST){
for(el=e; el; el = el->rhs()) {
ee = el->lhs();
if(ee->variant() != SPEC_PAIR)
return(0); // IO_control list error
kwe = isSgKeywordValExp(ee->lhs());
if(!kwe)
return(0);
if (!strcmp(kwe->value(),"unit"))
ioc[UNIT_RW] = ee->rhs();
else if (!strcmp(kwe->value(),"fmt"))
ioc[FMT_RW] = ee->rhs();
else if (!strcmp(kwe->value(),"nml"))
ioc[NML_RW] = ee->rhs();
else if (!strcmp(kwe->value(),"advance"))
ioc[ADVANCE_RW] = ee->rhs();
else if (!strcmp(kwe->value(),"async"))
ioc[ASYNC_RW] = ee->rhs();
else if (!strcmp(kwe->value(),"blank"))
ioc[BLANK_RW] = ee->rhs();
else if (!strcmp(kwe->value(),"decimal"))
ioc[DECIMAL_RW] = ee->rhs();
else if (!strcmp(kwe->value(),"delim"))
ioc[DELIM_RW] = ee->rhs();
else if (!strcmp(kwe->value(),"end"))
ioc[END_RW] = ee->rhs();
else if (!strcmp(kwe->value(),"err"))
ioc[ERR_RW] = ee->rhs();
else if (!strcmp(kwe->value(),"eor"))
ioc[EOR_RW] = ee->rhs();
else if (!strcmp(kwe->value(),"id"))
ioc[ID_RW] = ee->rhs();
else if (!strcmp(kwe->value(),"iomsg"))
ioc[IOMSG_RW] = ee->rhs();
else if (!strcmp(kwe->value(),"iostat"))
ioc[IOSTAT_RW] = ee->rhs();
else if (!strcmp(kwe->value(),"pad"))
ioc[PAD_RW] = ee->rhs();
else if (!strcmp(kwe->value(),"pos"))
ioc[POS_RW] = ee->rhs();
else if (!strcmp(kwe->value(),"rec"))
ioc[REC_RW] = ee->rhs();
else if (!strcmp(kwe->value(),"round"))
ioc[ROUND_RW] = ee->rhs();
else if (!strcmp(kwe->value(),"sign"))
ioc[SIGN_RW] = ee->rhs();
else if (!strcmp(kwe->value(),"size"))
ioc[SIZE_RW] = ee->rhs();
else
return(0);
}
if (!ioc[UNIT_RW]) return(0);
return(1);
}
else
return(0);
}
int control_list1(SgExpression *e, SgExpression *ioc[])
// analizes control list (e) for statements BACKSPACE,REWIND and ENDFILE
// and sets on ioc[]
{ SgKeywordValExp *kwe;
SgExpression *ee,*el;
int i;
for(i=NUM__R; i; i--)
ioc[i-1] = NULL;
if(e->variant() == SPEC_PAIR) {
ioc[UNIT_] = e->rhs();
return(1);
}
if(e->variant() == EXPR_LIST){
for(el=e; el; el = el->rhs()) {
ee = el->lhs();
if(ee->variant() != SPEC_PAIR)
return(0); // IO_control list error
kwe = isSgKeywordValExp(ee->lhs());
if(!kwe)
return(0);
if (!strcmp(kwe->value(),"unit"))
ioc[UNIT_] = ee->rhs();
else if (!strcmp(kwe->value(),"iostat"))
ioc[IOSTAT_] = ee->rhs();
else if (!strcmp(kwe->value(),"err"))
ioc[ERR_] = ee->rhs();
//else if (!strcmp(kwe->value(), "iomsg"))
// ioc[IOMSG_] = ee->rhs();
else
return(0);
}
return(1);
}
else
return(0);
}
int control_list_inquire (SgExpression *e, SgExpression *ioc[])
// analizes control list (e) INQUIRE statement
// and sets on ioc[]
{
SgKeywordValExp *kwe;
int i;
for(i=NUM__O+1; i; i--)
ioc[i-1] = NULL;
if(e->variant() == SPEC_PAIR && (kwe=isSgKeywordValExp(e->lhs())) && !strcmp(kwe->value(),"iolength")) { // case of INQUIRY (IOLENGTH = ...) outlist
ioc[NUM__O] = e->rhs();
return (1);
} else
return(control_list_open(e,ioc)); // control_list analisys
}
int control_list_open(SgExpression *e, SgExpression *ioc[])
// analizes control list (e) for OPEN,CLOSE and INQUIRE statements
// and sets on ioc[]
{ SgKeywordValExp *kwe;
SgExpression *ee,*el;
int i;
for(i=NUM__O; i; i--)
ioc[i-1] = NULL;
if(e->variant() == SPEC_PAIR) {
ioc[UNIT_] = e->rhs();
return(1);
}
if(e->variant() == EXPR_LIST){
for(el=e; el; el = el->rhs()) {
ee = el->lhs();
if(ee->variant() != SPEC_PAIR)
return(0); // IO_control list error
kwe = isSgKeywordValExp(ee->lhs());
if(!kwe)
return(0);
if (!strcmp(kwe->value(),"unit"))
ioc[UNIT_] = ee->rhs();
else if (!strcmp(kwe->value(),"file"))
ioc[FILE_] = ee->rhs();
else if (!strcmp(kwe->value(),"status"))
ioc[STATUS_] = ee->rhs();
else if (!strcmp(kwe->value(),"iostat"))
ioc[IOSTAT_] = ee->rhs();
else if (!strcmp(kwe->value(),"access"))
ioc[ACCESS_] = ee->rhs();
else if (!strcmp(kwe->value(),"err"))
ioc[ERR_] = ee->rhs();
else if (!strcmp(kwe->value(),"form"))
ioc[FORM_] = ee->rhs();
else if (!strcmp(kwe->value(),"recl"))
ioc[RECL_] = ee->rhs();
else if (!strcmp(kwe->value(),"blank"))
ioc[BLANK_] = ee->rhs();
else if (!strcmp(kwe->value(),"exist"))
ioc[EXIST_] = ee->rhs();
else if (!strcmp(kwe->value(),"opened"))
ioc[OPENED_] = ee->rhs();
else if (!strcmp(kwe->value(),"number"))
ioc[NUMBER_] = ee->rhs();
else if (!strcmp(kwe->value(),"named"))
ioc[NAMED_] = ee->rhs();
else if (!strcmp(kwe->value(),"name"))
ioc[NAME_] = ee->rhs();
else if (!strcmp(kwe->value(),"sequential"))
ioc[SEQUENTIAL_] = ee->rhs();
else if (!strcmp(kwe->value(),"direct"))
ioc[DIRECT_] = ee->rhs();
else if (!strcmp(kwe->value(),"nextrec"))
ioc[NEXTREC_] = ee->rhs();
else if (!strcmp(kwe->value(),"formatted"))
ioc[FORMATTED_] = ee->rhs();
else if (!strcmp(kwe->value(),"unformatted"))
ioc[UNFORMATTED_] = ee->rhs();
else if (!strcmp(kwe->value(),"position"))
ioc[POSITION_] = ee->rhs();
else if (!strcmp(kwe->value(),"action"))
ioc[ACTION_] = ee->rhs();
else if (!strcmp(kwe->value(),"readwrite"))
ioc[READWRITE_] = ee->rhs();
else if (!strcmp(kwe->value(),"read"))
ioc[READ_] = ee->rhs();
else if (!strcmp(kwe->value(),"write"))
ioc[WRITE_] = ee->rhs();
else if (!strcmp(kwe->value(),"delim"))
ioc[DELIM_] = ee->rhs();
else if (!strcmp(kwe->value(),"pad"))
ioc[PAD_] = ee->rhs();
else if (!strcmp(kwe->value(),"convert"))
ioc[CONVERT_] = ee->rhs();
else
return(0);
}
return(1);
}
else
return(0);
}
void InsertSendIOSTAT(SgExpression * eios)
{int imem;
SgType *t;
imem = ndvm;
doAssignStmtAfter(GetAddresMem(eios));
t = eios->symbol() ? Base_Type(eios->symbol()->type()) : SgTypeInt();//type of IOSTAT var
doAssignStmtAfter(TypeLengthExpr(t)); //type size
//doAssignStmtAfter(new SgValueExp(TypeSize(t))); 14.03.03
doCallAfter(SendMemory(1,imem,imem+1)); //count of memory areas = 1
if(dvm_debug)
InsertNewStatementAfter(D_Read(DVM000(imem)),cur_st,cur_st->controlParent());
SET_DVM(imem);
}
void InsertSendInquire(SgExpression * eioc[])
{int imem,j,i,icount;
imem = ndvm;
j=0;
if(eioc[NUM__O]) { // case of INQUIRY (IOLENGTH = ...) outlist
j=1;
doAssignStmtAfter(GetAddresMem(eioc[NUM__O]));
doAssignStmtAfter(TypeLengthExpr(eioc[NUM__O]->type()));
} else {
for (i=IOST_;i<ACTION_;i++)
if(eioc[i]) {
doAssignStmtAfter(GetAddresMem(eioc[i]));
j++;
}
for (i=IOST_;i<ACTION_;i++)
if(eioc[i])
doAssignStmtAfter(TypeLengthExpr(eioc[i]->type()));
//doAssignStmtAfter(new SgValueExp(TypeSize(eioc[i]->type()))); 14.03.03
}
if(j) {
icount = j; //count of memory areas
doCallAfter(SendMemory(icount,imem,imem+j));
if(dvm_debug)
for(i=0; i<j; i++)
InsertNewStatementAfter(D_Read(DVM000(imem+i)),cur_st,cur_st->controlParent());
}
SET_DVM(imem);
}
int isDependence(SgExpression *e,SgExpression *eprev)
{
if(!e || !eprev)
return 0;
if(ExpCompare(e, eprev))
return 1;
return (isDependence(e->lhs(),eprev) || isDependence(e->rhs(),eprev));
}
int ElementDependence(SgStatement *st_first, SgStatement *st, SgExpression *e)
{
SgStatement *st_next = st_first;
for(;st_next != st; st_next=st_next->lexNext())
if(isDependence(e,st_next->expr(1)->lhs()->lhs())) //st_next is dvm000(i)=getai(el), search for dependency between e and el
return 1;
return 0;
}
void SendList(SgStatement *st_first, SgExpression *iisize[], int imem, int j0, int nl)
{
SgStatement *st;
int i,j;
if(j0==nl) return;
for(j = j0,st=st_first; j<nl; j++,st = st->lexNext())
{
if( j!=j0 && (ElementDependence(st_first,st,st->expr(1)->lhs()->lhs()) || ElementDependence(st_first,st,iisize[j])))
break;
}
cur_st = st->lexPrev();
for(i=j0;i<j;i++)
doAssignStmtAfter(iisize[i]);
doCallAfter(SendMemory(j-j0,imem+j0,imem+nl+j0));
SendList(cur_st->lexNext(),iisize,imem,j,nl);
}
# define MAXLISTLEN 1000
void InsertSendInputList(SgExpression * input_list, SgExpression * io_stat,SgStatement *stmt)
{int imem,j,i,icount,iel;
SgExpression *el,*ein,*iisize[MAXLISTLEN],*iinumb[MAXLISTLEN],*iielem[MAXLISTLEN];
SgType *t;
SgStatement *st_save = cur_st;
imp_loop = NULL;
if(dvm_debug)
for(i=0;i<MAXLISTLEN;i++)
iinumb[i] = NULL;
imem = ndvm;
j=0;
for (el=input_list;el;el=el->rhs()) {
ein = el->lhs(); // input list item
if(j== MAXLISTLEN-2)
err("Compiler bug (in InsertSendInputList)",0,stmt);
if(isSgIOAccessExp(ein)) //implicit loop
{ if(!SpecialKindImplicitLoop(el->rhs(),ein,&j, iisize, iielem, iinumb, stmt))
ImplicitLoop(ein,&j, iisize, iielem, iinumb, stmt);
}
else if(isSgArrayRefExp(ein) && !ein->lhs() && (ein->type()->variant()!=T_STRING)){//whole array
doAssignStmtAfter(GetAddresMem(FirstArrayElement(ein->symbol())));
iisize[j] = InputItemLength(ein,stmt);
if(dvm_debug){
iielem[j] = ElemLength(ein->symbol());
iinumb[j] = NumbOfElem(iisize[j], iielem[j]);
}
j++;
}
else if(isSgArrayRefExp(ein) && (ein->type()->variant()==T_ARRAY)){//section of array
doAssignStmtAfter(GetAddresMem (ContinuousSection(ein) ? FirstElementOfSection(ein) : FirstArrayElement(ein->symbol())));
iisize[j] = InputItemLength(ein,stmt);
if(dvm_debug){
iielem[j] = ElemLength(ein->symbol());
iinumb[j] = NumbOfElem(iisize[j], iielem[j]);
}
j++;
}
else if(isSgRecordRefExp(ein) && ein->type()->variant() == T_ARRAY ) { //structure reference of ArrayType
SgExpression *ein_short = ArrayFieldLast(ein);
doAssignStmtAfter( GetAddresMem( isSgRecordRefExp(ein_short) ? FirstElementOfField(ein_short) : FirstElementOfSection(ein_short) ) );
iisize[j] = InputItemLength(ein_short,stmt);
if(dvm_debug){
iielem[j] = ElemLength(isSgRecordRefExp(ein_short) ? RightMostField(ein_short)->symbol() : ein_short->symbol());
iinumb[j] = NumbOfElem(iisize[j], iielem[j]);
}
j++;
}
else {
doAssignStmtAfter(GetAddresMem(ein->type()->variant()==T_ARRAY ? FirstElementOfSection(ein) : ein));
iisize[j] = InputItemLength(ein,stmt);
j++;
}
}
if(io_stat) {
doAssignStmtAfter(GetAddresMem(io_stat));
t = io_stat->symbol() ? Base_Type(io_stat->symbol()->type()) : SgTypeInt();//type of IOSTAT var
iisize[j] = TypeLengthExpr(t); //new SgValueExp(TypeSize(t));
j++;
}
SendList(st_save->lexNext(),iisize,imem,0,j);
if(dvm_debug){
for(i=0;i<j;i++)
if(iinumb[i] != NULL){ // input list item is array
iel = ndvm;
doAssignStmtAfter(iielem[i]);
doAssignStmtAfter(iinumb[i]);
InsertNewStatementAfter(D_ReadA(DVM000(imem+i),iel,iel+1),cur_st,cur_st->controlParent());
SET_DVM(iel);
} else
InsertNewStatementAfter(D_Read(DVM000(imem+i)),cur_st,cur_st->controlParent());
}
SET_DVM(imem);
}
int SpecialKindImplicitLoop(SgExpression *el, SgExpression *ein, int *pj, SgExpression *iisize[], SgExpression *iielem[],SgExpression *iinumb[],SgStatement *stmt)
{
SgExpression *ell, *e, *e1, *enumb, *elen, *bounds;
SgSymbol *s;
SgValueExp c1(1);
if(el) return(0); //number of input list items > 1
ell = ein->lhs();
if(ell->rhs()) return(0); //number of items of implicit loop list
e = ell->lhs(); s = e->symbol();
bounds = ein->rhs();
if(bounds->rhs()) return(0); //step of implicit loop is specified
if(isSgArrayRefExp(e) && (e->type()->variant()!=T_STRING) && Rank(s)==1 && (isSgVarRefExp(e->lhs()->lhs())) && (e->lhs()->lhs()->symbol() == ein->symbol()) ) {
e1 = &(e->copy());
e1->lhs()->setLhs(bounds->lhs()->lhs()->copy());
doAssignStmtAfter(GetAddresMem(e1)); //initial address of array section
enumb = &(bounds->lhs()->rhs()->copy() - bounds->lhs()->lhs()->copy() + c1);
elen = ElemLength(s);
iisize[*pj] = &(*enumb * (*elen)); //array section length
if(dvm_debug) {
iielem[*pj] = elen; //ElemLength(s);
iinumb[*pj] = enumb;
}
*pj = *pj+1;
return (1);
}
else
return(0);
}
void ImplicitLoop(SgExpression *ein, int *pj, SgExpression *iisize[], SgExpression *iielem[],SgExpression *iinumb[],SgStatement *stmt)
{
SgExpression *ell, *e;
for (ell = ein->lhs();ell;ell=ell->rhs()){ //looking through item list of implicit loop
e = ell->lhs();
if(isSgIOAccessExp(e))
ImplicitLoop(e,pj,iisize,iielem,iinumb,stmt);
else {
if(isSgArrayRefExp(e)) {
SgExpression *e1 ;
SgSymbol *ar;
int has_aster_or_1;
if(!e->lhs() && e->type()->variant()==T_STRING) {//character object
doAssignStmtAfter(GetAddresMem(e));
iisize[*pj] = InputItemLength(e,stmt);
*pj = *pj+1;
continue;
}
ar = e->symbol();
has_aster_or_1 = hasAsterOrOneInLastDim(ar); //testing last dimension : * or 1
if(! has_aster_or_1) {
if(isInSymbList(imp_loop,ar))
continue;
else
imp_loop = AddToSymbList(imp_loop,ar);
}
e1 = FirstArrayElement(ar);
doAssignStmtAfter(GetAddresMem(e1)); //initial array address
iisize[*pj] =ArrayLength(ar,stmt,0);// whole array length
if (has_aster_or_1) //testing last dimension : * or 1
{
if (ein->symbol() == lastDimInd(e->lhs()))
iisize[*pj] = CorrectLastOpnd(iisize[*pj], ar, ein->rhs(), stmt);
//correcting whole array length by implicit loop parameters
else
Error("Can not calculate array length: %s", ar->identifier(), 194, stmt);
}
if(dvm_debug) {
iielem[*pj] = ElemLength(ar);
iinumb[*pj] = NumbOfElem(iisize[*pj], iielem[*pj]);
}
*pj = *pj+1;
}
else if(e->variant() == ARRAY_OP) {//substring or substring of array element
SgExpression *e1 ;
if( !e->lhs()->lhs()) //substring
{
doAssignStmtAfter(GetAddresMem(e->lhs()));
iisize[*pj] = InputItemLength(e->lhs(),stmt);
*pj = *pj+1;
continue;
}
//substring of array element
e1 = FirstArrayElement(e->lhs()->symbol());
doAssignStmtAfter(GetAddresMem(e1)); //initial array address
iisize[*pj] = ArrayLength(e->lhs()->symbol(),stmt,1); // whole array length
*pj = *pj+1;
}
else {
doAssignStmtAfter(GetAddresMem(e));
iisize[*pj] = InputItemLength(e,stmt);
*pj = *pj+1;
}
}
}
}
/*
* variant when substring is represented by ARRAY_REF node with 2 operands
*
SgExpression * InputItemLength (SgExpression *e, SgStatement *stmt)
{
if (isSgVarRefExp(e))
return(new SgValueExp(TypeSize(e->type())));
if (isSgArrayRefExp(e))
if(e->type()->variant()!=T_STRING) //whole array or array element of non-character type
if(e->lhs()) //array element
return(new SgValueExp(TypeSize(e->symbol()->type()->baseType())));
else //whole array
return(ArrayLength(e->symbol(),stmt,1));
else { //variable, array element, substring or substring of array element of type CHARACTER
if(!(e->lhs())) //variable
return(StringLengthExpr(e->symbol()->type(),e->symbol()));
//return(new SgValueExp(CharLength(e->symbol()->type()))); 14.03.03
// e = e->lhs()->lhs(); //variant of e->lhs() is EXPR_LIST
if(!(e->rhs()) && (e->lhs()->lhs()->variant() != DDOT)) //array element of type CHARACTER
return(StringLengthExpr(e->symbol()->type()->baseType(),e->symbol()));
//return(new SgValueExp(CharLength(e->symbol()->type()->baseType())));
else
return(SubstringLength(e));
}
return(new SgValueExp(-1));
}
SgExpression *SubstringLength(SgExpression *sub)
{ //SgSubscriptExp *sbe;
SgValueExp c1(1);
SgExpression *e,*e1,*e2;
SgType *t;
//err("Sorry, substring length calculating is not jet implemented",cur_st);
if(sub->lhs()->lhs()->variant() == DDOT) { //substring(sub has variant EXPR_LIST)
e = sub->lhs()->lhs();
t=sub->symbol()->type();
}
else { //substring of array element
e = sub->rhs();
t=sub->symbol()->type()->baseType();
}
if(e->lhs())
e1 = &(e->lhs()->copy());
else
e1 = &(c1.copy());
if(e->rhs())
e2 = &(e->rhs()->copy());
else
e2 = StringLengthExpr(t,sub->symbol()); //new SgValueExp(CharLength(t)); 14.03.03
return (&(*e2 - *e1 + c1));
}
*/
SgExpression * InputItemLength (SgExpression *e, SgStatement *stmt)
{
if(isSgRecordRefExp(e))
{
e = RightMostField(e);
//printf("FIELD: %s %d ",(e->symbol() ? e->symbol()->identifier() : (char *)"----"),(e->type() ? e->type()->variant() : 0));
//printf(" LINE %d IN %s\n" ,stmt->lineNumber(),stmt->fileName() );
}
if (isSgVarRefExp(e))
return(TypeLengthExpr(e->type()));
//return(new SgValueExp(TypeSize(e->type()))); 14.03.03
if (isSgArrayRefExp(e))
{
if (e->symbol()->type()->variant() == T_STRING) // variable of type CHARACTER
return(StringLengthExpr(e->symbol()->type(), e->symbol()));
//return(new SgValueExp(CharLength(e->symbol()->type()))); 14.03.03
else
{
if (e->lhs() && !isSgArrayType(e->type())) //array element
return(TypeLengthExpr(e->symbol()->type()->baseType()));
else if (e->lhs() && isSgArrayType(e->type())) //array section
return(ContinuousSection(e) ? SectionLength(e, stmt, 1) : ArrayLength(e->symbol(), stmt, 1));
else //whole array
return(ArrayLength(e->symbol(), stmt, 1));
}
}
if (e->variant() == ARRAY_OP) //substring or substring of array element
return(SubstringLength(e)); //substring
return(new SgValueExp(-1));
}
SgExpression *SubstringLength(SgExpression *sub)
{ //SgSubscriptExp *sbe;
SgValueExp c1(1);
SgExpression *e,*e1,*e2;
SgType *t;
//err("Sorry, substring length calculating is not jet implemented",cur_st);
if(!sub->lhs()->lhs()){ //substring
t=sub->lhs()->symbol()->type();
e = sub->rhs()->lhs(); // sub->rhs() has variant EXPR_LIST
}
else{ //substring of array element
t=sub->lhs()->symbol()->type()->baseType();
e = sub->rhs();
}
if(e->lhs())
e1 = &(e->lhs()->copy());
else
e1 = &(c1.copy());
if(e->rhs())
e2 = &(e->rhs()->copy());
else
e2 = StringLengthExpr(t,sub->lhs()->symbol()); //new SgValueExp(CharLength(t));
return (&(*e2 - *e1 + c1));
}
SgExpression *ArrayLength(SgSymbol *ar, SgStatement *stmt, int err)
{int i,rank;
SgExpression *esize,*len;
rank = Rank(ar);
len = TypeLengthExpr(ar->type()->baseType()); //length of one array element
//len = new SgValueExp(TypeSize(ar->type()->baseType())); 14.03.03
for(i=1; i<=rank; i++) {
//calculating size of i-th dimension
esize = ReplaceParameter(ArrayDimSize(ar, i));
if(err && esize && esize->variant()==STAR_RANGE)
Error("Assumed-size array: %s",ar->identifier(),162,stmt);
if(esize->isInteger())
esize = new SgValueExp( esize->valueInteger());
if(esize)
len = &(*len * (*esize));
}
if (len->isInteger()) // calculating length if it is possible
len = new SgValueExp( len->valueInteger());
return(len);
}
SgExpression *SectionLength(SgExpression *ea, SgStatement *stmt, int err)
{int i,rank;
SgExpression *esize,*len, *el, *eup[MAX_DIMS], *ein[MAX_DIMS];
//rank = ArraySectionRank(ea);
rank = Rank(ea->symbol());
len = TypeLengthExpr(ea->symbol()->type()->baseType()); //length of one array element
for(i=0,el=ea->lhs(); i<rank && el; i++,el=el->rhs()) {
//calculating size of i-th dimension
UpperBoundInTriplet(el->lhs(),ea->symbol(),i,eup);
LowerBoundInTriplet(el->lhs(),ea->symbol(),i,ein);
esize = &(*eup[i] - *ein[i] + *new SgValueExp(1));
//if(err && esize && esize->variant()==STAR_RANGE)
// Error("Assumed-size array: %s",ar->identifier(),162,stmt);
//if(esize->isInteger())
// esize = new SgValueExp( esize->valueInteger());
if(esize)
len = &(*len * (*esize));
}
//if (len->isInteger()) // calculating length if it is possible
// len = new SgValueExp( len->valueInteger());
return(len);
}
SgExpression *ArrayLengthInElems(SgSymbol *ar, SgStatement *stmt, int err)
{int i,rank;
SgExpression *esize,*len;
rank = Rank(ar);
len = new SgValueExp(1);
for(i=1; i<=rank; i++) {
//calculating size of i-th dimension
esize = ReplaceParameter(ArrayDimSize(ar, i));
if(err && esize && esize->variant()==STAR_RANGE)
Error("Assumed-size array: %s",ar->identifier(),162,stmt);
if(esize->isInteger())
esize = new SgValueExp( esize->valueInteger());
if(esize)
len = &(*len * (*esize));
}
if (len->isInteger()) // calculating length if it is possible
len = new SgValueExp( len->valueInteger());
return(len);
}
SgExpression *NumbOfElem(SgExpression *es,SgExpression *el)
{SgExpression *e,*e1 = NULL,*ec;
if(!es)
return(NULL);
if(es->isInteger())
return(new SgValueExp( es->valueInteger() / el->valueInteger()));
//deleting on length of element
ec = &es->copy();
for(e=ec; e->variant() == MULT_OP; e=e->lhs())
e1 = e;
e1->setLhs(new SgValueExp(1)); //replace length of element by 1
return(ec);
}
SgExpression *ElemLength(SgSymbol *ar)
{SgExpression *len;
len = TypeLengthExpr(ar->type()->baseType()); //length of one array element
//len = new SgValueExp(TypeSize(ar->type()->baseType())); 14.03.03
return(len);
}
SgExpression *CorrectLastOpnd(SgExpression *len, SgSymbol *ar, SgExpression *bounds,SgStatement *stmt)
{SgExpression *elast;
SgValueExp c1(1);
if(!Rank(ar))
return(len); //error situation
if(!bounds->rhs()){ //step of implicit loop is absent ,by default 1
elast=&(bounds->lhs()->rhs()->copy() - *Exprn(LowerBound(ar,Rank(ar)-1)) + c1);
//upper_bound_of_implicit_loop - lower_bound_of_last_dimension_of_array + 1
if (elast->isInteger()) // calculating size if it is possible
elast = new SgValueExp( elast->valueInteger());
if(len->variant() == MULT_OP)
len->setRhs(elast); //replace last multiplicand of array length
else
len = &(*len * (*elast));//len is the length of array element,it is multiplied by elast
}
else // variant == SEQ,there is a step
Error("Can not calculate array length: %s", ar->identifier(),194,stmt);
if (len->isInteger()) // calculating length if it is possible
len = new SgValueExp( len->valueInteger());
return(len);
}
SgSymbol *lastDimInd(SgExpression *el)
{//returns symbol of last subscript expression if it is variable refference
//el - subscript list
SgExpression *last = NULL;
for(; el; el=el->rhs()) //search for last subscript
last = el->lhs();
if(isSgVarRefExp(last)) //is variable refference
return(last->symbol());
return(NULL);
}
int hasAsterOrOneInLastDim(SgSymbol *ar)
{//is dummy argument or array in COMMON declared as a(n,n,*) or a(1)
SgExpression *e;
SgValueExp *ev;
int rank;
rank = Rank(ar);
if(!rank)
return(0);
e=ArrayDimSize(ar,rank);
if(e->variant()==STAR_RANGE)
return(1);
if(rank==1 && (ev = isSgValueExp(e)) && ev->intValue() == 1)
return(1);
return(0);
}
SgExpression *FirstArrayElement(SgSymbol *ar)
{//generating reference AR(L1,...,Ln), where Li - lower bound of i-th dimension
int i;
SgExpression *esl, *el, *e;
el = NULL;
for (i = Rank(ar); i; i--){
esl = new SgExprListExp(*Exprn(LowerBound(ar,i-1)));
esl->setRhs(el);
el = esl;
}
e = new SgArrayRefExp(*ar);
e->setLhs(el);
return(e);
}
SgExpression *FirstElementOfSection(SgExpression *ea)
{SgExpression *el, *ein[MAX_DIMS];
int i,rank;
SgExpression *esl, *e;
SgSymbol * ar;
ar = ea->symbol();
rank = Rank(ar);
if(!ea->lhs()) //whole array
return(FirstArrayElement(ar));
for(el=ea->lhs(),i=0; el && i<rank; el=el->rhs(),i++)
LowerBoundInTriplet(el->lhs(),ar,i, ein);
el = NULL;
for (i = rank; i; i--){
esl = new SgExprListExp(*Exprn(ein[i-1]));
esl->setRhs(el);
el = esl;
}
e = new SgArrayRefExp(*ar);
e->setLhs(el);
return(e);
}
SgExpression *ArrayFieldLast(SgExpression *e)
{
while(isSgRecordRefExp(e) && RightMostField(e)->type()->variant() != T_ARRAY)
e=e->lhs();
//e->unparsestdout(); printf("\n");
return(e);
}
SgExpression *FirstElementOfField(SgExpression *e_RecRef)
{
SgExpression *estr = &e_RecRef->copy();
estr->setRhs(FirstElementOfSection(RightMostField(estr)) );
return (estr);
}
int ArraySectionRank(SgExpression *ea)
{SgExpression *el;
int rank;
for(el=ea->lhs(),rank=0; el; el=el->rhs())
if(el->lhs()->variant() == DDOT)
rank++;
return(rank);
}
int ContinuousSection(SgExpression *ea)
{ SgExpression *ei;
ei = ea->lhs();
if(ei->lhs()->variant() != DDOT)
return(0);
while(ei && isColon(ei->lhs()))
ei = ei->rhs();
if(!ei) // (:,:,...:)
return(1);
//if(ei->lhs()->variant() == DDOT && ei->lhs()->lhs()->variant() == DDOT) //there is step
// return (0);
ei = ei->rhs();
while(ei && ei->lhs()->variant() != DDOT)
ei = ei->rhs();
if(!ei)
return(1);
return(0);
}
int isColon(SgExpression *e)
{
if(!e)
return(0);
if(e->variant() == DDOT && !e->lhs() && !e->rhs())
return(1);
return(0);
}
int hasEndErrControlSpecifier(SgStatement *stmt, SgExpression *ioEnd[] )
{
SgExpression *el, *ee;
SgExpression *e = stmt->expr(1); //control list
ioEnd[0] = ioEnd[1] = ioEnd[2] = NULL;
if(!e) return 0;
if(e->variant() == EXPR_LIST){
for(el=e; el; el = el->rhs()) {
ee = el->lhs();
if(ee->variant() != SPEC_PAIR)
return 0; // IO_control list error
SgKeywordValExp *kwe = isSgKeywordValExp(ee->lhs());
if(!kwe)
return 0;
if (!strcmp(kwe->value(),"iostat"))
return 0;
else if (!strcmp(kwe->value(),"err"))
ioEnd[0] = el;
else if (!strcmp(kwe->value(),"end"))
ioEnd[1] = el;
//else if (!strcmp(kwe->value(),"eor"))
// ioEnd[2] = el;
else
continue;
}
if(ioEnd[0] || ioEnd[1] || ioEnd[2])
return 1;
else
return 0;
}
else
return 0;
}
void ChangeSpecifierByIOSTAT(SgExpression *e)
{
// e->variant() == SPEC_PAIR
e->setLhs( new SgKeywordValExp("iostat"));
e->setRhs( new SgVarRefExp(IOstatSymbol()) ) ;
}
void ChangeControlList(SgStatement *stmt, SgExpression *ioEnd[] )
{
SgExpression *el;
// replace one of the specifiers with IOSTAT
for(el=stmt->expr(1); el; el=el->rhs())
if(el==ioEnd[0] || el==ioEnd[1] || el==ioEnd[2])
{
ChangeSpecifierByIOSTAT(el->lhs());
break;
}
// delete others
while(el->rhs())
{
if(el->rhs()==ioEnd[0] || el->rhs()==ioEnd[1] || el->rhs()==ioEnd[2])
{
el->setRhs(el->rhs()->rhs());
continue;
}
else
el=el->rhs();
}
return;
}
void ReplaceStatementWithEndErrSpecifier(SgStatement *stmt, SgExpression *ioEnd[] )
{
int i;
for(i=0; i<3; i++)
if(ioEnd[i])
doLogIfForIOstat(IOstatSymbol(),ioEnd[i]->lhs(),stmt);
ChangeControlList(stmt,ioEnd);
}
/*--------------------------------------------------------------------------------------*/
/* RTS2 interface */
/*--------------------------------------------------------------------------------------*/
static inline int strcmpi(const char *s1, const char *s2) {
size_t l1 = strlen(s1);
size_t l2 = strlen(s2);
size_t min_l = (l1 < l2? l1 : l2);
char c1, c2;
for (size_t i = 0; i < min_l; ++i) {
c1 = tolower(s1[i]);
c2 = tolower(s2[i]);
if (c1 > c2) return 1;
else if (c1 < c2) return -1;
}
if (l1 > min_l) return 1;
else if (l2 > min_l) return -1;
return 0;
}
const char *stringValuesOfArgs(int argNumber, SgStatement *stmt) {
int variant = stmt->variant();
if (variant == OPEN_STAT || variant == CLOSE_STAT) return openCloseArgStrings[argNumber];
else if (variant == READ_STAT || variant == WRITE_STAT) return readWriteArgStrings[argNumber];
else if (variant == ENDFILE_STAT || variant == REWIND_STAT || variant == BACKSPACE_STAT) return filePositionArgsStrings[argNumber];
return NULL;
};
bool checkDefaultStringArg(SgExpression *arg, const char **possible_values, int count, int i, SgStatement *stmt, int error_msg) {
// if default-string arg isn't a value expression, it can't be checked.
if (!(arg && isSgValueExp(arg))) return true;
SgValueExp *v = isSgValueExp(arg);
char *string_val = v->stringValue();
for (int string_arg_number = 0; string_arg_number < count; ++string_arg_number)
if (!strcmpi(string_val, possible_values[string_arg_number])) return true;
const char *stringArg = stringValuesOfArgs(i, stmt);
if (error_msg)
Error("Wrong value of '%s' argument in IO-statement", stringArg, 454, stmt);
return false;
}
bool checkLabelRefArg(SgExpression *arg, SgStatement *stmt, int error_msg) {
if (!arg) return true;
SgLabelRefExp *lbl = isSgLabelRefExp(arg);
if (!lbl) {
if (error_msg)
err("Wrong type of label argument", 450, stmt);
return false;
}
return true;
}
bool checkIntArg(SgExpression *arg, int i, SgStatement *stmt, int error_msg) {
if (!arg) return true;
SgValueExp *val = isSgValueExp(arg);
SgVarRefExp *var = isSgVarRefExp(arg);
if (val && val->variant() == INT_VAL) return true;
if (var && var->symbol()->type()->variant() == T_INT) return true;
if (arg->type()->variant() == T_INT) return true;
const char *stringArg = stringValuesOfArgs(i, stmt);
if (error_msg)
Error("Wrong type of '%s' argument in IO-statement", stringArg, 450, stmt);
return false;
}
bool checkStringArg(SgExpression *arg, int i, SgStatement *stmt, int error_msg) {
if (!arg) return true;
SgValueExp *val = isSgValueExp(arg);
SgArrayRefExp *arr = isSgArrayRefExp(arg);
if (val && val->variant() == STRING_VAL) return true;
if (arr && arr->symbol()->type()->variant() == T_STRING) return true;
if (arg->type()->variant() == T_STRING) return true;
const char *stringArg = stringValuesOfArgs(i, stmt);
if (error_msg)
Error("Wrong type of '%s' argument in IO-statement", stringArg, 450, stmt);
return false;
}
bool checkStringVarArg(SgExpression *arg, int i, SgStatement *stmt, int error_msg) {
if (!arg) return true;
SgArrayRefExp *arr = isSgArrayRefExp(arg);
if (!arr || arr->symbol()->type()->variant() != T_STRING) {
const char *stringArg = stringValuesOfArgs(i, stmt);
if (error_msg)
Error("Wrong type of '%s' argument in IO-statement", stringArg, 450, stmt);
return false;
}
return true;
}
bool checkVarRefIntArg(SgExpression *arg, int i, SgStatement *stmt, int error_msg) {
if (!arg) return true;
SgVarRefExp *var = isSgVarRefExp(arg);
if (!var || !(var->symbol()->type()->variant() == T_INT)) {
const char *stringArg = stringValuesOfArgs(i, stmt);
if (error_msg)
Error("Wrong type of '%s' argument in IO-statement", stringArg, 450, stmt);
return false;
}
return true;
}
bool checkUnitAndNewUnit(SgExpression **ioc, SgStatement *stmt, int error_msg) {
if (ioc[UNIT_IO] && ioc[NEWUNIT_IO]) {
if (error_msg)
err("Wrong combination of arguments: both unit and newunit arguments specified", 452, stmt);
return false;
}
if (!ioc[UNIT_IO] && !ioc[NEWUNIT_IO]) {
if (error_msg)
err("Neither unit nor newunit specified in OPEN statement", 451, stmt);
return false;
}
return true;
}
// forbids sequential and direct access
bool checkAccessArg(SgExpression **ioc, SgStatement *stmt, int error_msg) {
// stream access is not a default value, so if access it omitted, there's an error
if (!ioc[ACCESS_IO]) {
if (error_msg)
err("Only stream access is allowed in parallel IO", 455, stmt);
return false;
}
SgValueExp *access = isSgValueExp(ioc[ACCESS_IO]);
if (!access) return true;
if (!strcmpi(access->stringValue(), "stream")) return true;
if (error_msg)
err("Only stream access is allowed in parallel IO", 455, stmt);
return false;
}
// forbids formatted input
bool checkFormArg(SgExpression **ioc, SgStatement *stmt, int error_msg) {
// if access is stream, default form argument value is formatted
// if access isn't stream, this stmt is already treated as wrong
if (!ioc[FORM_IO]) return true;
SgValueExp *form = isSgValueExp(ioc[FORM_IO]);
if (!form) return true;
if (!strcmpi(form->stringValue(), "unformatted")) return true;
if (error_msg)
err("Formatted form is not allowed in parallel IO", 455, stmt);
return false;
}
bool checkFormattedArgs(SgExpression **ioc, SgStatement *stmt, int error_msg) {
/* if form specifier is omitted, it's considered to be unformatted. */
SgExpression *form = ioc[FORM_IO];
if (!form || (form && isSgValueExp(form) && !strcmpi(isSgValueExp(form)->stringValue(), "unformatted"))) {
if (ioc[BLANK_IO] || ioc[DECIMAL_IO] || ioc[DELIM_IO] || ioc[ENCODING_IO] || ioc[PAD_IO] || ioc[ROUND_IO] || ioc[SIGN_IO])
{
if (error_msg)
err("Formatted arguments used in unformatted IO.", 453, stmt);
return false;
}
}
return true;
}
bool checkStatusArg(SgExpression **ioc, SgStatement *stmt, int error_msg) {
if (!ioc[STATUS_IO]) return true;
if (!isSgValueExp(ioc[STATUS_IO])) return true;
char *string_val = isSgValueExp(ioc[STATUS_IO])->stringValue();
if ((!strcmpi(string_val, "new") || !strcmpi(string_val, "replace")) && !ioc[FILE_IO]) {
if (error_msg)
err("Wrong combination of arguments: if status argument is \"new\" or \"replace\", file argument shall be specified", 452, stmt);
return false;
}
if (!strcmpi(string_val, "scratch") && ioc[FILE_IO]) {
if (error_msg)
err("Wrong combination of arguments: if status argument is \"scratch\", file argument shall not be specified", 452, stmt);
return false;
}
return true;
}
bool checkDvmModeArg(char const *io_modes_str, SgStatement *stmt, int error_msg) {
if (!io_modes_str || !io_modes_str[0]) return true;
bool l = false;
bool p = false;
for (int i = 0; *io_modes_str && i < 3; ++i) {
if (io_modes_str[i] == 'l') l = true;
else if (io_modes_str[i] == 'p') p = true;
}
if (l && p) {
if (error_msg)
err("Wrong combination of arguments: local and parallel mode simultaneously used", 452, stmt);
return false;
}
return true;
}
bool checkNewunitArgument(SgExpression **ioc, SgStatement *stmt, int error_msg) {
/*
If the NEWUNIT= specifier appears in an OPEN statement, either the FILE= specifier shall appear, or the STATUS= specifier shall appear with a value of SCRATCH. The unit identified by a NEWUNIT value shall not be preconnected.
newunit ==> (file xor status == 'scratch')
!(newunit ==> (file xor status == 'scratch'))
!(!newunit || (file xor status == 'scratch'))
newunit && !(file xor status == 'scratch')
a xor b = (!a^b || a^!b)
newunit && !( (file && status != 'scratch') || (!file && status == 'scratch') )
newunit && !(file && status != 'scratch') && !(!file && status == 'scratch')
newunit && (!file || status == 'scratch') && (file || status != 'scratch')
*/
SgExpression *newunit = ioc[NEWUNIT_IO];
SgExpression *file = ioc[FILE_IO];
SgExpression *status = ioc[STATUS_IO];
bool status_scratch = (status && !isSgValueExp(status)) || (status && isSgValueExp(status) && !strcmpi(isSgValueExp(status)->stringValue(), "scratch"));
bool status_not_scratch = !status || (status && isSgValueExp(status) && strcmpi(isSgValueExp(status)->stringValue(), "scratch"));
if (newunit && (!file || status_scratch) && (file || status_not_scratch)) {
if (error_msg)
err("Wrong combination of arguments: newunit argument shall be specified together with either file argument, or with status argument equal to \"scratch\"", 452, stmt);
return false;
}
return true;
}
bool checkFileArg(SgExpression **ioc, SgStatement *stmt, int error_msg) {
// FILE ARG If this specifier is omitted and the unit is not connected to a file, the STATUS= specifier shall be specified with a value of SCRATCH
// !((file && !unit) -> status='scratch') = ((file && !unit) && !status='scratch')
if (isSgVarRefExp(ioc[STATUS_IO])) return true;
if (ioc[FILE_IO] && !ioc[UNIT_IO] && ioc[STATUS_IO] && isSgValueExp(ioc[STATUS_IO]) && strcmpi(isSgValueExp(ioc[STATUS_IO])->stringValue(), "scratch")) {
if (error_msg)
err("Wrong combination of arguments: file argument specified, unit not specified and status isn't \"scratch\"", 452, stmt);
return false;
}
return true;
}
bool checkReclArg(SgExpression **ioc, SgStatement *stmt, int error_msg) {
/*
The value of the RECL= specifier shall be positive.
This specifier shall not appear when a file is being connected for stream access.
This specifier shall appear when a file is being connected for direct access.
*/
SgExpression *recl = ioc[RECL_IO];
SgExpression *access = ioc[ACCESS_IO];
if (isSgVarRefExp(recl)) return true;
if (recl && isSgValueExp(recl)->intValue() <= 0) {
if (error_msg)
err("Wrong value of argument: recl argument should be positive", 455, stmt);
return false;
}
if (isSgVarRefExp(access)) return true;
if (recl && access && isSgValueExp(access) && !(strcmpi(isSgValueExp(access)->stringValue(), "stream"))) {
if (error_msg)
err("Wrong combination of arguments: recl argument used with stream file", 452, stmt);
return false;
}
if (!recl && access && isSgValueExp(access) && !(strcmpi(isSgValueExp(access)->stringValue(), "direct"))) {
if (error_msg)
err("Wrong combination of arguments: recl argument should be used with direct file", 452, stmt);
return false;
}
return true;
}
bool checkPosArg(SgExpression **ioc, SgStatement *stmt, int error_msg) {
// The connection shall be for sequential or stream access.
// error if is position is specefied, access is scecified and access is direct
SgExpression *access = ioc[ACCESS_IO]; // default is sequantal, so, it's correct if it's omitted
if (isSgValueExp(access)) return true;
if (ioc[POSITION_IO] && access && !strcmpi(isSgValueExp(access)->stringValue(), "direct")) {
if (error_msg)
err("Wrong combination of arguments: position argument may be specified only for direct and sequential access", 452, stmt);
return false;
}
return true;
}
bool checkArgsClose(SgExpression **ioc, SgStatement *stmt, int error_msg) {
bool correct = true;
if (!checkIntArg(ioc[UNIT_IO], UNIT_IO, stmt, error_msg)) correct = false;
if (!checkLabelRefArg(ioc[ERR_IO], stmt, error_msg)) correct = false;
if (!checkVarRefIntArg(ioc[IOSTAT_IO], IOSTAT_IO, stmt, error_msg)) correct = false;
if (!checkStringVarArg(ioc[IOMSG_IO], IOMSG_IO, stmt, error_msg)) correct = false;
if (!checkStringArg(ioc[STATUS_IO], STATUS_IO, stmt, error_msg)) correct = false;
if (!correct) return false;
const char *pos_val_status[] = { "keep", "delete" };
if (!checkDefaultStringArg(ioc[STATUS_IO], pos_val_status, 2, STATUS_IO, stmt, error_msg)) correct = false;
return correct;
}
bool checkArgsOpen(SgExpression **ioc, SgStatement *stmt, int error_msg, char const *io_modes_str) {
// for every argument we should check if it has a correct type
// then check some special restricitions
// then check that all the arguments have correct values
bool correct = true;
if (!checkLabelRefArg(ioc[ERR_IO], stmt, error_msg)) correct = false;
if (!checkIntArg(ioc[UNIT_IO], UNIT_IO, stmt, error_msg)) correct = false;
if (!checkIntArg(ioc[RECL_IO], RECL_IO, stmt, error_msg)) correct = false;
if (!checkStringArg(ioc[ACCESS_IO], ACCESS_IO, stmt, error_msg)) correct = false;
if (!checkStringArg(ioc[ACTION_IO], ACTION_IO, stmt, error_msg)) correct = false;
if (!checkStringArg(ioc[ASYNC_IO], ASYNC_IO, stmt, error_msg)) correct = false;
if (!checkStringArg(ioc[BLANK_IO], BLANK_IO, stmt, error_msg)) correct = false;
if (!checkStringArg(ioc[DECIMAL_IO], DECIMAL_IO, stmt, error_msg)) correct = false;
if (!checkStringArg(ioc[DELIM_IO], DELIM_IO, stmt, error_msg)) correct = false;
if (!checkStringArg(ioc[ENCODING_IO], ENCODING_IO, stmt, error_msg)) correct = false;
if (!checkStringArg(ioc[FILE_IO], FILE_IO, stmt, error_msg)) correct = false;
if (!checkStringArg(ioc[FORM_IO], FORM_IO, stmt, error_msg)) correct = false;
if (!checkStringArg(ioc[PAD_IO], PAD_IO, stmt, error_msg)) correct = false;
if (!checkStringArg(ioc[POSITION_IO], POSITION_IO, stmt, error_msg)) correct = false;
if (!checkStringArg(ioc[ROUND_IO], ROUND_IO, stmt, error_msg)) correct = false;
if (!checkStringArg(ioc[SIGN_IO], SIGN_IO, stmt, error_msg)) correct = false;
if (!checkStringArg(ioc[STATUS_IO], STATUS_IO, stmt, error_msg)) correct = false;
// dvm io mode produces mistake!
if (!checkStringArg(ioc[DVM_MODE_IO], DVM_MODE_IO, stmt, error_msg)) correct = false;
if (!checkVarRefIntArg(ioc[IOSTAT_IO], IOSTAT_IO, stmt, error_msg)) correct = false;
if (!checkVarRefIntArg(ioc[NEWUNIT_IO], NEWUNIT_IO, stmt, error_msg)) correct = false;
if (!checkStringVarArg(ioc[IOMSG_IO], IOMSG_IO, stmt, error_msg)) correct = false;
if (!correct) return false;
/* FILE argument may have any value; it shouldn't checked */
const int string_args[14] = { ACCESS_IO, ACTION_IO, ASYNC_IO, BLANK_IO, DECIMAL_IO, DELIM_IO, ENCODING_IO /*, FILE_IO */, FORM_IO, PAD_IO, POSITION_IO, ROUND_IO, SIGN_IO, STATUS_IO, DVM_MODE_IO };
const char *pos_val_access[] = { "sequental", "direct", "stream" }; //3
const char *pos_val_action[] = { "read", "write", "readwrite"}; //3
const char *pos_val_async[] = { "yes", "no"}; // 2
const char *pos_val_blank[] = { "null", "zero"}; // 2
const char *pos_val_decimal[] = { "comma", "point"}; // 2
const char *pos_val_delim[] = { "apostrophe", "quote", "none" }; // 3
const char *pos_val_encoding[] = { "utf-8", "default"}; // 2
const char *pos_val_form[] = { "formatted", "unformatted"}; // 2
const char *pos_val_pad[] = { "yes", "no"}; // 2
const char *pos_val_position[] = { "asis", "rewind", "append"}; // 3
const char *pos_val_round[] = { "up", "down", "zero", "nearest", "compatible", "processor_defined" }; // 6
const char *pos_val_sign[] = { "plus", "suppress", "processor_defined" }; // 3
const char *pos_val_status[] = { "old", "new", "replace", "unknown" }; // 4
const char **pos_values[] = {pos_val_access, pos_val_action, pos_val_async, pos_val_blank, pos_val_decimal, pos_val_delim, pos_val_encoding,
pos_val_form, pos_val_pad, pos_val_position, pos_val_round, pos_val_sign, pos_val_status };
const int arg_count[] = { 3, 3, 2, 2, 2, 3, 2, 2, 2, 3, 6, 3, 4 };
for (int i = 0; i < 13; ++i) {
if (!checkDefaultStringArg(ioc[string_args[i]], pos_values[i], arg_count[i], string_args[i], stmt, error_msg))
correct = false;
}
if (!checkAccessArg(ioc, stmt, error_msg)) correct = false;
if (!checkFormArg(ioc, stmt, error_msg)) correct = false;
if (!checkFormattedArgs(ioc, stmt, error_msg)) correct = false;
if (!checkPosArg(ioc, stmt, error_msg)) correct = false;
if (!checkUnitAndNewUnit(ioc, stmt, error_msg)) correct = false;
if (!checkNewunitArgument(ioc, stmt, error_msg)) correct = false;
if (!checkReclArg(ioc, stmt, error_msg)) correct = false;
if (!checkStatusArg(ioc, stmt, error_msg)) correct = false;
if (!checkDvmModeArg(io_modes_str, stmt, error_msg)) correct = false;
return correct;
}
bool checkArgsEnfileRewind(SgExpression **ioc, SgStatement *stmt, int error_msg) {
/*
DVMH_API void dvmh_ftn_endfile_(const DvmType *pUnit, const VarRef *pErrFlagRef, const VarRef *pIOStatRef, const StringVarRef *pIOMsg);
DVMH_API void dvmh_ftn_rewind_(const DvmType *pUnit, const VarRef *pErrFlagRef, const VarRef *pIOStatRef, const StringVarRef *pIOMsg);
*/
bool correct = true;
if (stmt->variant() == BACKSPACE_STAT) {
if (error_msg)
warn("Backspace statement isn't implemented in new IO", 0, stmt); // FIXME: error number
correct = false;
}
if (!checkIntArg(ioc[UNIT_], UNIT_, stmt, error_msg)) correct = false;
if (!ioc[UNIT_]) {
if (error_msg)
err("Unit argument not specified in file position statement", 456, stmt);
correct = false;
}
if (!checkLabelRefArg(ioc[ERR_], stmt, error_msg)) correct = false;
if (!checkVarRefIntArg(ioc[IOSTAT_],IOSTAT_, stmt, error_msg)) correct = false;
if (!checkStringVarArg(ioc[IOMSG_], IOMSG_, stmt, error_msg)) correct = false;
return correct;
}
bool checkArgsRW(SgExpression **ioc, SgStatement *stmt, int error_msg) {
bool correct = true;
/* these arguments are forbidden in both new and old IO: blank, delim, decimal, eor, pad, sign */
if (ioc[BLANK_RW] || ioc[DELIM_RW] || ioc[DECIMAL_RW] || ioc[EOR_RW] || ioc[PAD_RW] || ioc[SIGN_RW] || ioc[ROUND_RW])
{
if (error_msg)
err("Arguments forbidden in both new and old IO used", 453, stmt); // FIXME: number or error?
correct = false;
}
/* these arguments are forbidden only in new IO, so only warning should be showed */
/* these arguments aren't added to argument, so it's unnessecary to care about what will be with them */
if (ioc[FMT_RW] || ioc[NML_RW] || ioc[ADVANCE_RW] || ioc[REC_RW] || ioc[SIZE_RW]) {
if (error_msg)
warn("Arguments not allowed in new IO used", 453, stmt); // FIXME: number or error?
correct = false;
}
checkIntArg(ioc[UNIT_RW], UNIT_RW, stmt, error_msg);
if (stmt->variant() == WRITE_STAT && ioc[END_RW]) {
if (error_msg)
err("Illegal elements in control list", 185, stmt);
correct = false;
}
else if (!checkLabelRefArg(ioc[END_RW], stmt, error_msg)) correct = false;
if (!checkLabelRefArg(ioc[ERR_RW], stmt, error_msg)) correct = false;
if (!checkVarRefIntArg(ioc[IOSTAT_RW], IOSTAT_RW, stmt, error_msg)) correct = false;
if (!checkStringVarArg(ioc[IOMSG_RW], IOMSG_RW, stmt, error_msg)) correct = false;
if (!checkIntArg(ioc[POS_RW], POS_RW, stmt, error_msg)) correct = false;
SgExprListExp *items = isSgExprListExp(isSgInputOutputStmt(stmt)->itemList());
if (items == NULL) {
if (ioc[NML_RW]) {
if (error_msg)
warn("Namelist argument is not supported in new IO", 457, stmt); // FIXME: error number
return false; // further checking is unnecceasry, because there's no item to reading/writing
}
else {
if (error_msg)
err("Subject for reading/writing not specified", 457, stmt);
return false; // further checking is unnecceasry, because there's no item to reading/writing
}
}
if (stmt->variant() == READ_STAT) {
for (int i = 0; i < items->length(); ++i) {
SgExpression *item = items->elem(i);
if (!(item->variant() == VAR_REF || item->variant() == ARRAY_REF || item->variant() == ARRAY_OP)) {
if (error_msg)
err("Wrong type of argument in IO-statement: reading item is not a variable", 450, stmt);
correct = false;
}
}
}
/* array expressions are not yet implemented in new IO, but are allowed in old IO */
else {
for (int i = 0; i < items->length(); ++i) {
SgExpression *item = items->elem(i);
// forbidding array expressions such as A+B
// substrings, array elements and sections are still allowed
if (isSgArrayType(item->type()) && !item->symbol()) {
if (error_msg)
warn("Not implemented item type for writing in new IO: array expressions", 458, stmt);
correct = false;
}
}
}
return correct;
}
SgStatement *IfConnected(SgStatement *stmt, SgExpression *unit, bool suitableForNewIO)
{
// generate If construct:
// if (dvmh_ftn_connected ( unit,suitableForNewIO ) then
// CONTINUE
// else
// stmt
// endif
SgValueExp one(1);
SgStatement *cp = stmt->controlParent();
cur_st = stmt->lexNext();
stmt->extractStmt();
SgStatement *trueBody = new SgStatement(CONT_STAT); //CONTINUE statement
SgStatement *falseBody = stmt;
SgExpression *failIfYes = suitableForNewIO ? ConstRef(0) : ConstRef(1); // ????????
SgIfStmt *ifst = new SgIfStmt(SgEqOp(*DvmhConnected(DvmType_Ref(unit), failIfYes), one), *trueBody, *falseBody);
cur_st->insertStmtBefore(*ifst, *cp);
cur_st = trueBody;
if (stmt-> hasLabel()) { // IO statement has label
// the label of IO statement is transfered on IF statement
BIF_LABEL(stmt->thebif) = NULL;
ifst->setLabel(*stmt->label());
}
char *cmnt=stmt-> comments();
if (cmnt) { // IO statement has preceeding comments
// the comment of IO statement is transfered on IF statement
BIF_CMNT(stmt->thebif) = NULL;
ifst -> setComments(cmnt);
}
return ifst;
}
int control_list_open_new(SgExpression *e, SgExpression *ioc[])
// analizes control list (e) for OPEN
// and sets on ioc[]
{ SgKeywordValExp *kwe;
SgExpression *ee,*el;
int i;
for(i=NUMB__CL; i; i--)
ioc[i-1] = NULL;
if(e->variant() == SPEC_PAIR) {
kwe = isSgKeywordValExp(e->lhs());
if (!kwe || !strcmp(kwe->value(), "unit"))
ioc[UNIT_IO] = e->rhs();
else if (!strcmp(kwe->value(), "newunit"))
ioc[NEWUNIT_IO] = e->rhs();
else return 0;
return(1);
}
if(e->variant() == EXPR_LIST){
for(el=e; el; el = el->rhs()) {
ee = el->lhs();
if(ee->variant() != SPEC_PAIR)
return(0); // IO_control list error
kwe = isSgKeywordValExp(ee->lhs());
if(!kwe)
return(0);
if (!strcmp(kwe->value(),"unit"))
ioc[UNIT_IO] = ee->rhs();
else if (!strcmp(kwe->value(),"access"))
ioc[ACCESS_IO] = ee->rhs();
else if (!strcmp(kwe->value(),"action"))
ioc[ACTION_IO] = ee->rhs();
else if (!strcmp(kwe->value(),"async"))
ioc[ASYNC_IO] = ee->rhs();
else if (!strcmp(kwe->value(),"blank"))
ioc[BLANK_IO] = ee->rhs();
else if (!strcmp(kwe->value(),"decimal"))
ioc[DECIMAL_IO] = ee->rhs();
else if (!strcmp(kwe->value(),"delim"))
ioc[DELIM_IO] = ee->rhs();
else if (!strcmp(kwe->value(),"encoding"))
ioc[ENCODING_IO] = ee->rhs();
else if (!strcmp(kwe->value(),"file"))
ioc[FILE_IO] = ee->rhs();
else if (!strcmp(kwe->value(),"form"))
ioc[FORM_IO] = ee->rhs();
else if (!strcmp(kwe->value(),"iostat"))
ioc[IOSTAT_IO] = ee->rhs();
else if (!strcmp(kwe->value(),"iomsg"))
ioc[IOMSG_IO] = ee->rhs();
else if (!strcmp(kwe->value(),"newunit"))
ioc[NEWUNIT_IO] = ee->rhs();
else if (!strcmp(kwe->value(),"pad"))
ioc[PAD_IO] = ee->rhs();
else if (!strcmp(kwe->value(),"position"))
ioc[POSITION_IO] = ee->rhs();
else if (!strcmp(kwe->value(),"recl"))
ioc[RECL_IO] = ee->rhs();
else if (!strcmp(kwe->value(),"round"))
ioc[ROUND_IO] = ee->rhs();
else if (!strcmp(kwe->value(),"sign"))
ioc[SIGN_IO] = ee->rhs();
else if (!strcmp(kwe->value(),"status"))
ioc[STATUS_IO] = ee->rhs();
else if (!strcmp(kwe->value(),"err"))
ioc[ERR_IO] = ee->rhs();
else
return(0);
}
return(1);
}
else
return(0);
}
int control_list_close_new(SgExpression *e, SgExpression *ioc[])
// analizes control list (e) for CLOSE
// and sets on ioc[]
{ SgKeywordValExp *kwe;
SgExpression *ee,*el;
int i;
for(i=NUMB__CL; i; i--)
ioc[i-1] = NULL;
if(e->variant() == SPEC_PAIR) {
kwe = isSgKeywordValExp(e->lhs());
if (!kwe || !strcmp(kwe->value(), "unit"))
ioc[UNIT_IO] = e->rhs();
else return 0;
return(1);
}
if(e->variant() == EXPR_LIST){
for(el=e; el; el = el->rhs()) {
ee = el->lhs();
if(ee->variant() != SPEC_PAIR)
return(0); // IO_control list error
kwe = isSgKeywordValExp(ee->lhs());
if(!kwe)
return(0);
if (!strcmp(kwe->value(),"unit"))
ioc[UNIT_IO] = ee->rhs();
else if (!strcmp(kwe->value(),"iostat"))
ioc[IOSTAT_IO] = ee->rhs();
else if (!strcmp(kwe->value(),"iomsg"))
ioc[IOMSG_IO] = ee->rhs();
else if (!strcmp(kwe->value(),"err"))
ioc[ERR_IO] = ee->rhs();
else if (!strcmp(kwe->value(),"status"))
ioc[STATUS_IO] = ee->rhs();
else
return(0);
}
if (!ioc[UNIT_IO]) return(0);
return(1);
}
else
return(0);
}
//enum class ArgType : int { NUMBER = 0, STRING = 1, VAR = 2, STRINGVAR = 3 };
enum { NUMBER_ARG, STRING_ARG, VAR_ARG, STRING_VAR_ARG };
int addArgToCall(SgExpression *ioc[], int type, SgCallStmt *call, int arg)
{
if (!ioc[arg])
call->addArg(*ConstRef(0));
else
switch (type) {
case NUMBER_ARG:
call->addArg(*DvmType_Ref(ioc[arg]));
break;
case STRING_ARG:
call->addArg(*DvmhString(ioc[arg]));
break;
case VAR_ARG:
call->addArg(*DvmhVariable(ioc[arg]));
break;
case STRING_VAR_ARG:
call->addArg(*DvmhStringVariable(ioc[arg]));
break;
default:
return 1;
}
return 0;
}
int addArgToCalls(SgExpression *ioc[], int type, SgCallStmt **calls, int ncalls, int arg) {
if (!ioc[arg])
for (int i = 0; i < ncalls; ++i)
calls[i]->addArg(*ConstRef(0));
else
switch (type) {
case NUMBER_ARG:
for (int i = 0; i < ncalls; ++i)
calls[i]->addArg(*DvmType_Ref(ioc[arg]));
break;
case STRING_ARG:
for (int i = 0; i < ncalls; ++i)
calls[i]->addArg(*DvmhString(ioc[arg]));
break;
case VAR_ARG:
for (int i = 0; i < ncalls; ++i)
calls[i]->addArg(*DvmhVariable(ioc[arg]));
break;
case STRING_VAR_ARG:
for (int i = 0; i < ncalls; ++i)
calls[i]->addArg(*DvmhStringVariable(ioc[arg]));
break;
default:
return 1;
}
return 0;
}
/* for inserting assignment dvm000(index) = 0 after cur_st. insertation is made only if cond = true */
void OccupyDvm000Elem(SgExpression *cond, int index) {
if (cond) {
SgValueExp *zero = new SgValueExp(0);
SgStatement *ass = new SgAssignStmt (*DVM000(index), *zero);
cur_st->lastNodeOfStmt()->insertStmtAfter(*ass, *cur_st->controlParent());
cur_st = ass;
}
}
/* for inserting if statement : if (dvm000(index) .ne. 0 goto ... */
void InsertGotoStmt(SgExpression *err, int index) {
if (err) {
SgValueExp *zero = new SgValueExp(0);
SgGotoStmt *gotostmt = new SgGotoStmt(*isSgLabelRefExp(err)->label());
SgIfStmt *ifst = new SgIfStmt(SgNeqOp(*DVM000(index), *zero), *gotostmt);
cur_st->lastNodeOfStmt()->insertStmtAfter(*ifst, *cur_st->controlParent());
cur_st = ifst;
}
}
void addRefArgToCall(SgExpression *ref_arg, SgCallStmt *call) {
if (ref_arg) call->addArg(*DvmhVariable(DVM000(ndvm++)));
else call->addArg(*ConstRef(0));
return;
}
void addRefArgToCalls(SgExpression *err, SgCallStmt **calls, int ncalls, int *indeces) {
for (int i = 0; i < ncalls; ++i) {
indeces[i] = ndvm;
addRefArgToCall(err, calls[i]);
}
}
void Dvmh_Close(SgExpression *ioc[]) {
/*
DVMH_API void dvmh_ftn_close_(
const DvmType *pUnit,
const VarRef *pErrFlagRef,
const VarRef *pIOStatRef,
const StringVarRef *pIOMsg,
const StringRef *pStatus);
*/
SgStatement *continue_st = cur_st; //true body of IF construct
fmask[FTN_CLOSE] = 2;
SgCallStmt *close_call = new SgCallStmt(*fdvm[FTN_CLOSE]);
int index_before = ndvm;
addArgToCall(ioc, NUMBER_ARG, close_call, UNIT_IO);
int index_err = ndvm;
addRefArgToCall(ioc[ERR_IO], close_call);
int index_iostat = ndvm;
addRefArgToCall(ioc[IOSTAT_IO], close_call);
addArgToCall(ioc, STRING_VAR_ARG, close_call, IOMSG_IO);
addArgToCall(ioc, STRING_ARG, close_call, STATUS_IO);
OccupyDvm000Elem(ioc[ERR_IO], index_err);
OccupyDvm000Elem(ioc[IOSTAT_IO], index_iostat);
//InsertNewStatementAfter(close_call, cur_st, stmt->controlParent());
doCallAfter(close_call);
if (ioc[IOSTAT_IO]) doAssignTo_After(ioc[IOSTAT_IO], DVM000(index_iostat));
InsertGotoStmt(ioc[ERR_IO], index_err);
continue_st->extractStmt();
SET_DVM(index_before);
return;
}
void Dvmh_Open(SgExpression *ioc[], const char *io_modes_str)
{
/*
DVMH_API void dvmh_ftn_open_(
const DvmType *pUnit,
const StringRef *pAccess,
const StringRef *pAction,
const StringRef *pAsync,
const StringRef *pBlank,
const StringRef *pDecimal,
const StringRef *pDelim,
const StringRef *pEncoding,
const StringRef *pFile,
const StringRef *pForm,
const VarRef *pErrFlagRef,
const VarRef *pIOStatRef,
const StringVarRef *pIOMsg,
const VarRef *pNewUnitRef,
const StringRef *pPad,
const StringRef *pPosition,
const DvmType *pRecl,
const StringRef *pRound,
const StringRef *pSign,
const StringRef *pStatus,
const StringRef *pDvmMode); */
SgStatement *continue_st = cur_st; //true body of IF construct
if (io_modes_str) ioc[DVM_MODE_IO] = new SgValueExp(io_modes_str);
int index_before = ndvm;
fmask[FTN_OPEN] = 2;
SgCallStmt *open_call = new SgCallStmt(*fdvm[FTN_OPEN]);
addArgToCall(ioc, NUMBER_ARG, open_call, UNIT_IO);
addArgToCall(ioc, STRING_ARG, open_call, ACCESS_IO);
addArgToCall(ioc, STRING_ARG, open_call, ACTION_IO);
addArgToCall(ioc, STRING_ARG, open_call, ASYNC_IO);
addArgToCall(ioc, STRING_ARG, open_call, BLANK_IO);
addArgToCall(ioc, STRING_ARG, open_call, DECIMAL_IO);
addArgToCall(ioc, STRING_ARG, open_call, DELIM_IO);
addArgToCall(ioc, STRING_ARG, open_call, ENCODING_IO);
addArgToCall(ioc, STRING_ARG, open_call, FILE_IO);
addArgToCall(ioc, STRING_ARG, open_call, FORM_IO);
int index_err = ndvm;
addRefArgToCall(ioc[ERR_IO], open_call);
int index_iostat = ndvm;
addRefArgToCall(ioc[IOSTAT_IO], open_call);
addArgToCall(ioc, STRING_VAR_ARG, open_call, IOMSG_IO);
int index_newunit = ndvm;
addRefArgToCall(ioc[NEWUNIT_IO], open_call);
addArgToCall(ioc, STRING_ARG, open_call, PAD_IO);
addArgToCall(ioc, STRING_ARG, open_call, POSITION_IO);
addArgToCall(ioc, NUMBER_ARG, open_call, RECL_IO);
addArgToCall(ioc, STRING_ARG, open_call, ROUND_IO);
addArgToCall(ioc, STRING_ARG, open_call, SIGN_IO);
addArgToCall(ioc, STRING_ARG, open_call, STATUS_IO);
addArgToCall(ioc, STRING_ARG, open_call, DVM_MODE_IO);
OccupyDvm000Elem(ioc[ERR_IO], index_err);
OccupyDvm000Elem(ioc[IOSTAT_IO], index_iostat);
OccupyDvm000Elem(ioc[NEWUNIT_IO], index_newunit);
doCallAfter(open_call);
if (ioc[IOSTAT_IO]) doAssignTo_After(ioc[IOSTAT_IO], DVM000(index_iostat));
if (ioc[NEWUNIT_IO]) doAssignTo_After(ioc[NEWUNIT_IO], DVM000(index_newunit));
InsertGotoStmt(ioc[ERR_IO], index_err);
continue_st->extractStmt();
SET_DVM(index_before);
return;
}
void Dvmh_FilePosition(SgExpression *ioc[], int variant) {
/*
DVMH_API void dvmh_ftn_endfile_(const DvmType *pUnit, const VarRef *pErrFlagRef, const VarRef *pIOStatRef, const StringVarRef *pIOMsg);
DVMH_API void dvmh_ftn_rewind_(const DvmType *pUnit, const VarRef *pErrFlagRef, const VarRef *pIOStatRef, const StringVarRef *pIOMsg);
*/
SgStatement *continue_st = cur_st; //true body of IF construct
SgCallStmt *call;
if (variant == ENDFILE_STAT) {
call = new SgCallStmt(*fdvm[FTN_ENDFILE]);
fmask[FTN_ENDFILE] = 2;
}
else {
call = new SgCallStmt(*fdvm[FTN_REWIND]);
fmask[FTN_REWIND] = 2;
}
int index_before = ndvm;
addArgToCall(ioc, NUMBER_ARG, call, UNIT_);
int index_iostat = ndvm;
addRefArgToCall(ioc[IOSTAT_], call);
int index_err = ndvm;
addRefArgToCall(ioc[ERR_], call);
addArgToCall(ioc, STRING_VAR_ARG, call, IOMSG_);
OccupyDvm000Elem(ioc[ERR_], index_err);
OccupyDvm000Elem(ioc[IOSTAT_], index_iostat);
doCallAfter(call);
if (ioc[IOSTAT_]) doAssignTo_After(ioc[IOSTAT_], DVM000(index_iostat));
InsertGotoStmt(ioc[ERR_], index_err);
continue_st->extractStmt();
SET_DVM(index_before);
return;
}
SgExpression *ArrNoSubs(SgExpression *expr) {
SgArrayRefExp *arr = isSgArrayRefExp(expr);
// second part of conjunction is for excluding characters, that also are ArrayRefExp
if (arr && isSgArrayType(expr->symbol()->type()))
return new SgArrayRefExp(*arr->symbol());
return expr;
}
void Dvmh_ReadWrite(SgExpression **ioc, SgStatement *stmt) {
/*
DVMH_API void dvmh_ftn_read_unf_(
const DvmType *pUnit,
const VarRef *pEndFlagRef,
const VarRef *pErrFlagRef,
const VarRef *pIOStatRef,
const StringVarRef *pIOMsg,
const DvmType *pPos,
const DvmType dvmDesc[],
const DvmType *pSpecifiedFlag,
...);
*/
/* dvmh_ftn_write_unf() different from read by the absence of the flag pEnd.
DVMH_API void dvmh_ftn_write_unf_(
const DvmType *pUnit,
const VarRef *pErrFlagRef,
const VarRef *pIOStatRef,
const StringVarRef *pIOMsg,
const DvmType *pPos,
const DvmType dvmDesc[],
const DvmType *pSpecifiedRank, ...);
*/
SgStatement *continue_st = cur_st; //true body of IF construct
SgInputOutputStmt *io_stmt = isSgInputOutputStmt(stmt);
SgExprListExp *items = isSgExprListExp(io_stmt->itemList());
if (!items) return; // empty items case. for example, when namelist is used
int ncalls = items->length();
SgCallStmt *calls[1000]; //ncalls
if (stmt->variant() == READ_STAT) {
for (int i = 0; i < ncalls; ++i)
calls[i] = new SgCallStmt(*fdvm[FTN_READ]);
fmask[FTN_READ] = 2;
}
else {
for (int i = 0; i < ncalls; ++i)
calls[i] = new SgCallStmt(*fdvm[FTN_WRITE]);
fmask[FTN_WRITE] = 2;
}
int index_before = ndvm;
addArgToCalls(ioc, NUMBER_ARG, calls, ncalls, UNIT_RW);
int *i_endf = new int[ncalls];
int *i_errf = new int[ncalls];
if (stmt->variant() == READ_STAT)
addRefArgToCalls(ioc[END_RW], calls, ncalls, i_endf);
addRefArgToCalls(ioc[ERR_RW], calls, ncalls, i_errf);
int *i_iostat = new int[ncalls];
addRefArgToCalls(ioc[IOSTAT_RW], calls, ncalls, i_iostat);
addArgToCalls(ioc, STRING_VAR_ARG, calls, ncalls, IOMSG_RW);
addArgToCalls(ioc, NUMBER_ARG, calls, ncalls, POS_RW);
/*
inserting arguments, describing variables and array
for each arument:
1) if it is dvm-array, adding sections
2) if it is not-dvm array, insert data_enter before and data_exit after and adding sections
3) if it is scalar expression, insert only data_enter and data_exit
*/
for (int i_call = 0; i_call < ncalls; ++i_call) {
SgExpression *item = items->elem(i_call);
// Data_enter inserting and adding VarGenHeader argument for everything, that is not a dvm-array
if (!(isSgArrayRefExp(item) && HEADER(item->symbol()))) {
doCallAfter(DataEnter(ArrNoSubs(item), ConstRef_F95(0)));
calls[i_call]->addArg(*VarGenHeader(ArrNoSubs(item)));
}
// array reference
SgArrayRefExp *arr = isSgArrayRefExp(item);
if (arr) {
if (arr && HEADER(arr->symbol())) {
// it should be register_array(arr(1)), not register_array(arr)
SgExprListExp *new_subs = new SgExprListExp(*new SgValueExp(1));
SgArrayRefExp *new_array_ref = new SgArrayRefExp(*arr->symbol(), *new_subs);
calls[i_call]->addArg(*Register_Array_H2(new_array_ref));
}
if (arr->numberOfSubscripts()) {
int nsubs = arr->numberOfSubscripts();
calls[i_call]->addArg(*ConstRef(nsubs));
for (int i = nsubs-1; i >= 0; --i) {
SgExpression *lbound;
SgExpression *ubound;
SgSubscriptExp *sub;
// both bounds specified
if ((sub = isSgSubscriptExp(arr->subscript(i)))) {
lbound = sub->lbound();
ubound = sub->ubound();
lbound = (lbound? DvmType_Ref(lbound): ConstRef_F95(-2147483648));
ubound = (ubound? DvmType_Ref(ubound): ConstRef_F95(-2147483648));
}
// only upper bound specified
else {
lbound = ubound = DvmType_Ref(arr->subscript(i));
}
calls[i_call]->addArg(*lbound);
calls[i_call]->addArg(*ubound);
}
}
else // array doesn't have subscript or it is an array expression
calls[i_call]->addArg(*ConstRef(0));
}
else // it isn't array, anyhow it should be specified that there's no sections
calls[i_call]->addArg(*ConstRef(0));
}
/* inserting function calling and goto statements in case of error occurring */
for (int i_call = 0; i_call < ncalls; ++i_call) {
OccupyDvm000Elem(ioc[END_RW], i_endf[i_call]);
OccupyDvm000Elem(ioc[ERR_RW], i_errf[i_call]);
OccupyDvm000Elem(ioc[IOSTAT_RW], i_iostat[i_call]);
doCallAfter(calls[i_call]);
if (ioc[IOSTAT_RW]) doAssignTo_After(ioc[IOSTAT_RW], DVM000(i_iostat[i_call]));
InsertGotoStmt(ioc[END_RW], i_endf[i_call]);
InsertGotoStmt(ioc[ERR_RW], i_errf[i_call]);
}
/* for every not-dvm-array item, data_exit should be inserted */
SgExpression *item;
for (int i_call = 0; i_call < ncalls; ++i_call) {
if (items) item = items->elem(i_call);
else item = ConstRef(0);
if (!(isSgArrayRefExp(item) && HEADER(item->symbol()))) {
SgStatement *data_exit = DataExit(ArrNoSubs(ArrNoSubs(item)), 1);
cur_st->lastNodeOfStmt()->insertStmtAfter(*data_exit, *cur_st->controlParent());
cur_st = data_exit;
}
}
continue_st->extractStmt();
SET_DVM(index_before);
return;
}
Reference in New Issue Copy Permalink