void KeywordList( void ) {
//===========================
bool morelist;
if( RecNextOpr( OPR_EQU ) ) {
morelist = true;
} else {
if( Permission( IO_UNIT ) ) {
Unit();
AdvanceITPtr();
} else {
NextComma();
}
if( FormatIdentifier() ) {
if( Permission( IO_FMT ) ) {
FormatIdd();
AdvanceITPtr();
} else {
NextComma();
}
}
morelist = RecComma();
}
if( morelist ) {
for(;;) {
GetItem();
if( !RecComma() ) break;
}
}
CheckList(); // check that list had necessities ( unit )
// also remember if end= is specified
}
void ScanExpr(void) {
//==================
// Advance CITNode to the end of the current expression.
//
// Stops on: level zero comma
// level zero colon
// unmatched right parenthesis
// terminator
int level;
level = 0;
for(;;) {
if( RecOpenParen() ) {
level++;
} else if( RecCloseParen() ) {
level--;
}
if( ( RecComma() || RecColon() ) && ( level == 0 ) ) break;
if( level < 0 ) break;
if( RecTrmOpr() ) break;
AdvanceITPtr();
}
}
void DetCallList(void) {
//=====================
itnode *cit;
cit = CITNode;
AdvanceITPtr();
if( RecNOpn() ) {
AdvanceITPtr();
} else {
SetDefinedStatus();
AdvanceITPtr();
while( RecComma() ) {
if( CheckColon() ) {
Extension( SS_FUNCTION_VALUE );
SubStrArgs( cit );
Detach( cit );
return;
}
if( RecNOpn() ) break;
SetDefinedStatus();
AdvanceITPtr();
}
}
if( !RecCloseParen() ) {
Error( PC_NO_CLOSEPAREN );
}
Detach( cit );
}
bool StartImpDo( void ) {
//====================
// This procedure scans the i/o list to recognize an implied do.
// If it is not found false returns, if it is found true returns and:
// - the implied DO is initialized
// - a terminal operator is placed over the comma at the
// end of the i/o list within the implied DO. This is used
// as a signal to generate closing code for the implied DO.
// - the nodes containing the do list are released from
// from the internal text list.
// - a null operator is placed over the bracket at the
itnode *citnode;
itnode *lastcomma;
int level;
if( !RecNOpn() )
return( false );
if( !RecNextOpr( OPR_LBR ) )
return( false );
citnode = CITNode;
AdvanceITPtr();
lastcomma = NULL;
level = 0;
AdvanceITPtr();
for(;;) {
if( RecOpenParen() ) {
level++;
} else if( RecCloseParen() ) {
level--;
} else if( RecComma() && ( level == 0 ) ) {
lastcomma = CITNode;
}
if( ( level < 0 ) || RecTrmOpr() ) {
CITNode = citnode;
return( false );
}
AdvanceITPtr();
if( RecEquSign() && ( level == 0 ) ) {
break;
}
}
if( ( lastcomma == NULL ) || ( lastcomma->link != CITNode ) ) {
CITNode = citnode;
return( false );
}
InitImpDo( lastcomma );
CITNode = citnode;
AdvanceITPtr();
if( ( RecNextOpr( OPR_TRM ) && RecNOpn() ) ) {
Error( IL_EMPTY_IMP_DO );
}
return( true );
}
void CpIntrinsic(void) {
//=====================
// Compile INTRINSIC statement.
// INTRINSIC FUNC {,FUNC1} . . .
unsigned_16 flags;
IFF func;
sym_id sym_ptr;
TYPE func_typ;
for(;;) {
if( ReqName( NAME_INTRINSIC ) ) {
func = IFLookUp();
if( func > 0 ) {
func_typ = IFType( func );
sym_ptr = LkSym();
flags = sym_ptr->u.ns.flags;
if( ( flags & SY_USAGE ) != 0 ) {
if( ( flags & SY_CLASS ) == SY_SUBPROGRAM ) {
if( ( flags & SY_INTRINSIC ) != 0 ) {
Error( SR_PREV_INTRNSC );
} else if( ( flags & SY_EXTERNAL ) != 0 ) {
Error( SR_INTRNSC_EXTRN );
}
} else {
IllName( sym_ptr );
}
} else if( flags & ERR_MASK ) {
IllName( sym_ptr );
} else if( ( flags & SY_TYPE ) &&
( sym_ptr->u.ns.u1.s.typ != func_typ ) ) {
NameTypeErr( TY_TYP_PREV_DEF, sym_ptr );
} else {
// we must OR the flags since SY_TYPE and/or SY_REFERENCED
// bit might already be set in the symbol table
sym_ptr->u.ns.flags |= SY_USAGE | SY_SUBPROGRAM |
SY_FUNCTION | SY_INTRINSIC;
func_typ = IFType( func );
sym_ptr->u.ns.u1.s.typ = func_typ;
sym_ptr->u.ns.xt.size = TypeSize( func_typ );
sym_ptr->u.ns.si.fi.index = func;
}
} else {
Error( SR_NOT_INTRNSC );
}
}
AdvanceITPtr();
if( !RecComma() ) {
break;
}
}
ReqEOS();
}
void DetSubList(void) {
//====================
itnode *cit;
int count;
byte no_subs;
itnode *save_cit;
uint ch_size;
if( CITNode->opn.us & USOPN_FLD ) {
no_subs = _DimCount( CITNode->sym_ptr->u.fd.dim_ext->dim_flags );
} else {
no_subs = _DimCount( CITNode->sym_ptr->u.ns.si.va.u.dim_ext->dim_flags );
}
count = 0;
cit = CITNode;
AdvanceITPtr();
while( RecComma() || RecFBr() ) {
if( CheckColon() ) {
if( count == 0 ) {
save_cit = CITNode;
CITNode = cit;
OpndErr( SV_TRIED_SSTR );
CITNode = save_cit;
} else if( count != no_subs ) {
Error( SV_INV_SSCR );
}
SubStrArgs( cit );
cit->opn.us &= ~USOPN_WHAT;
cit->opn.us |= USOPN_ASS;
Detach( cit );
return;
}
if( RecNOpn() ) break;
++count;
CkScrStr();
AdvanceITPtr();
}
if( !RecCloseParen() ) {
Error( PC_NO_CLOSEPAREN );
}
if( count != no_subs ) {
Error( SV_INV_SSCR );
}
// we must make sure the array isn't substrung before we can set OPN_SS1
if( !( cit->opn.us & USOPN_FLD ) && ( cit->sym_ptr->u.ns.u1.s.typ == FT_CHAR ) ) {
ch_size = cit->sym_ptr->u.ns.xt.size;
if( ch_size > 0 ) {
cit->opn.us |= USOPN_SS1;
cit->value.st.ss_size = ch_size;
}
}
Detach( cit );
}
static bool FormatIdentifier( void ) {
//====================================
if( RecComma() && RecNextOpr( OPR_EQU ) )
return false;
if( RecCloseParen() )
return false;
if( RecTrmOpr() )
return false;
ReqComma();
return true;
}
static unsigned_32 DoLabel( void )
{
unsigned_32 term;
if( RecNumber() ) {
term = LkUpDoTerm();
AdvanceITPtr();
if( !RecNOpr() && !RecComma() ) {
Error( DO_NO_COMMA_OR_VAR );
}
} else {
term = 0;
}
return( term );
}
static void CkNameNoList( void ) {
//==============================
// Check that array/subprogram with no list is alright.
if( ( ASType & AST_IO ) && RecTrmOpr() && RecNextOpr( OPR_TRM ) ) {
if( ( CITNode->opn.us & USOPN_WHAT ) != USOPN_ARR ) {
ClassErr( SV_NO_LIST, CITNode->sym_ptr );
}
return;
}
if( ( !RecNextOpr( OPR_COM ) && !RecNextOpr( OPR_RBR ) ) ||
( !RecComma() && !RecFBr() ) ) {
ClassErr( SV_NO_LIST, CITNode->sym_ptr );
}
}
void CpSave( void ) {
//================
// Compile SAVE statement : SAVE A1 {,A2 ... }
//
// where Ai is 1. a common block name preceded and followed by a /
// 2. an array name
// 3. a variable name
sym_id sym_ptr;
if( RecNOpn() && RecNextOpr( OPR_TRM ) ) {
if( ( (SgmtSw & SG_LITTLE_SAVE) != 0 ) || ( (SgmtSw & SG_BIG_SAVE) != 0 ) ) {
Error( SA_SAVED );
}
SgmtSw |= SG_BIG_SAVE;
} else {
for( ;; ) {
if( RecNOpn() && RecNextOpr( OPR_DIV ) ) {
AdvanceITPtr();
if( ReqName( NAME_COMMON ) ) {
sym_ptr = LkCommon();
if( sym_ptr->u.ns.flags == 0 ) {
sym_ptr->u.ns.flags |= SY_USAGE | SY_COMMON;
}
Save( sym_ptr );
}
AdvanceITPtr();
ReqDiv();
ReqNOpn();
} else if( ReqName( NAME_VAR_OR_ARR ) ) {
sym_ptr = LkSym();
if( ( sym_ptr->u.ns.flags & ~SV_ON_OR_OFF ) != SY_VARIABLE ) {
IllName( sym_ptr );
} else {
Save( sym_ptr );
}
}
AdvanceITPtr();
if( !RecComma() ) {
break;
}
}
ReqEOS();
}
}
static void NextComma( void ) {
//=================================
int level;
AdvanceITPtr();
level = 0;
for(;;) {
if( RecOpenParen() ) {
level++;
} else if( RecCloseParen() ) {
level--;
}
if( level < 0 )
break;
if( RecEOS() )
break;
if( RecComma() && ( level == 0 ) )
break;
AdvanceITPtr();
}
}
static void DataDo( TYPE do_type ) {
//=====================================
// Process an implied-DO for DATA statements.
sym_id do_var;
do_type = do_type;
do_var = CITNode->sym_ptr;
AdvanceITPtr();
DoExpr(); // process e1
if( ReqComma() ) {
DoExpr(); // process e2
if( RecComma() ) {
DoExpr(); // process e3
} else {
PushConst( 1 ); // indicate unit incrementation
}
}
EmitOp( FC_DATA_DO_LOOP );
OutPtr( do_var );
}
void CpExternal(void) {
//====================
// Compile EXTERNAL statement.
// EXTERNAL PROC {,PROC1} . . .
sym_id sym;
unsigned_16 flags;
for(;;) {
if( ReqName( NAME_EXT_PROC ) ) {
sym = LkSym();
flags = sym->u.ns.flags;
if( ( flags & SY_CLASS ) == SY_SUBPROGRAM ) {
if( ( flags & SY_EXTERNAL ) != 0 ) {
Error( SR_EXTRNED_TWICE );
} else if( ( flags & SY_INTRINSIC ) != 0 ) {
Error( SR_INTRNSC_EXTRN );
}
} else if( ( flags & SY_USAGE ) != 0 ) {
IllName( sym );
} else {
flags = SY_USAGE | SY_SUBPROGRAM | SY_EXTERNAL;
if( ( sym->u.ns.flags & SY_TYPE ) != 0 ) {
flags |= SY_FUNCTION;
}
sym->u.ns.flags |= flags;
if( ( Options & OPT_REFERENCE ) == 0 ) {
sym->u.ns.flags |= SY_RELAX_EXTERN;
}
}
}
AdvanceITPtr();
if( !RecComma() ) break;
}
ReqEOS();
}
void CpVolatile( void ) {
//====================
// Compile VOLATILE statement.
// VOLATILE VAR {,VAR1} . . .
sym_id sym;
for(;;) {
if( ReqName( NAME_VAR_OR_ARR ) ) {
sym = LkSym();
if( (sym->ns.flags & ~ERR_MASK ) != SY_VARIABLE ) {
IllName( sym );
} else {
sym->ns.xflags |= SY_VOLATILE;
}
}
AdvanceITPtr();
if( !RecComma() ) break;
}
ReqEOS();
}
void SFPrologue( void ) {
//====================
// Generate code for statement function prologue.
sym_id sym;
itnode *func_node;
itnode *arg_list;
sf_parm **parm;
StmtSw |= SS_SF_REFERENCED;
CkTypeDeclared();
SFSymId = CITNode->sym_ptr;
if( ( SFSymId->ns.typ == FT_CHAR ) && ( SFSymId->ns.xt.size == 0 ) ) {
Error( SF_ILL_CHAR_LEN );
} else if( SFSymId->ns.typ == FT_STRUCTURE ) {
Error( SF_ILL_TYPE );
}
GStartSF();
SFSymId->ns.flags = SY_USAGE | SY_TYPE | SY_SUBPROGRAM | SY_STMT_FUNC;
CITNode->flags = SFSymId->ns.flags;
func_node = CITNode;
AdvanceITPtr();
ReqOpenParen();
SFSymId->ns.si.sf.header = FMemAlloc( sizeof( sf_header ) );
SFSymId->ns.si.sf.header->ref_count = 1;
parm = &SFSymId->ns.si.sf.header->parm_list;
*parm = NULL;
if( RecNOpn() ) {
AdvanceITPtr();
} else {
for(;;) {
if( ReqName( NAME_SF_DUMMY ) ) {
sym = LkSym();
sym->ns.xflags |= SY_DEFINED;
CkTypeDeclared();
if( ( ( sym->ns.flags & SY_CLASS ) == SY_VARIABLE ) &&
( ( sym->ns.flags & SY_SUBSCRIPTED ) == 0 ) &&
( ( sym->ns.typ != FT_CHAR ) ||
( sym->ns.xt.size != 0 ) ) &&
( sym->ns.typ != FT_STRUCTURE ) ) {
if( sym->ns.flags & SY_SPECIAL_PARM ) {
Error( SF_DUPLICATE_DUMMY_PARM );
} else {
*parm = FMemAlloc( sizeof( sf_parm ) );
(*parm)->link = NULL;
(*parm)->actual = sym;
(*parm)->shadow = STShadow( sym );
parm = &((*parm)->link);
}
} else {
Error( SF_ILL_DUMMY_PARM );
}
}
AdvanceITPtr();
if( !RecComma() ) break;
}
}
ReqCloseParen();
ReqNOpn();
arg_list = func_node->link;
func_node->link = CITNode->link;
CITNode->link = NULL;
CITNode = func_node;
FreeITNodes( arg_list );
}
void CpEquivalence(void) {
//=======================
// Compile EQUIVALENCE statement.
// EQUIVALENCE (A1,...,An) {,(B1,...,Bm)} . . .
sym_id sym;
int num_equived;
intstar4 *subscripts;
int eq_size;
act_eq_entry *new_eq;
act_eq_entry *eqv_entry;
act_eq_entry *eq_head;
act_eq_entry *eq_set;
bool ill_name;
bool sub_strung;
act_eq_entry equiv;
eq_set = EquivSets;
if( EquivSets != NULL ) {
while( eq_set->next_eq_set != NULL ) {
eq_set = eq_set->next_eq_set;
}
}
for(;;) {
if( RecNOpn() ) {
AdvanceITPtr();
}
ReqOpenParen();
eqv_entry = NULL;
eq_head = NULL;
num_equived = 0;
for(;;) {
AError = FALSE;
if( ReqName( NAME_VAR_OR_ARR ) ) {
num_equived++;
sym = LkSym();
ill_name = TRUE;
if( ( sym->ns.flags & SY_CLASS ) == SY_VARIABLE ) {
if( sym->ns.flags & SY_DATA_INIT ) {
NameErr( ST_DATA_ALREADY, sym );
} else if( sym->ns.flags & SY_SUB_PARM ) {
IllName( sym );
} else if( ( sym->ns.flags & SY_SUBSCRIPTED ) &&
_Allocatable( sym ) ) {
IllName( sym );
} else {
sym->ns.flags |= SY_IN_EQUIV;
ill_name = FALSE;
}
} else {
IllName( sym );
}
AdvanceITPtr();
equiv.name_equived = sym;
equiv.next_eq_entry = NULL;
equiv.next_eq_set = NULL;
equiv.subs_no = 0;
equiv.substr = 0;
equiv.substr1 = 1;
equiv.substr2 = 0;
subscripts = equiv.subscrs;
if( RecOpenParen() ) {
if( !RecNOpn() || !RecNextOpr( OPR_COL ) ) {
sub_strung = FALSE;
for(;;) {
CIntExpr();
*subscripts = ITIntValue( CITNode );
AdvanceITPtr();
if( RecColon() ) {
sub_strung = TRUE;
break;
}
subscripts++;
equiv.subs_no++;
if( equiv.subs_no == MAX_DIM ) break;
if( !RecComma() ) break;
}
if( !sub_strung ) {
ReqCloseParen();
ReqNOpn();
AdvanceITPtr();
if( RecOpenParen() ) {
*subscripts = 1;
if( !RecNOpn() ) {
CIntExpr();
*subscripts = ITIntValue( CITNode );
}
AdvanceITPtr();
sub_strung = ReqColon();
}
}
} else {
sub_strung = TRUE;
}
if( sub_strung ) {
equiv.substr = 1;
if( SubStr2( subscripts ) ) {
equiv.substr = 2;
}
}
}
if( AError ) {
equiv.subs_no = 0;
equiv.substr = 0;
}
if( ( ( SgmtSw & SG_SYMTAB_RESOLVED ) == 0 ) && !ill_name ) {
eq_size = sizeof( eq_entry ) +
equiv.subs_no * sizeof( intstar4 );
if( equiv.substr != 0 ) {
eq_size += 2 * sizeof( intstar4 );
}
new_eq = FMemAlloc( eq_size );
memcpy( new_eq, &equiv, eq_size );
if( eqv_entry == NULL ) {
eq_head = new_eq;
eqv_entry = new_eq;
} else {
eqv_entry->next_eq_entry = new_eq;
eqv_entry = new_eq;
}
if( sym->ns.si.va.vi.ec_ext == NULL ) {
sym->ns.si.va.vi.ec_ext = STComEq();
}
}
} else {
AdvanceITPtr();
}
if( !RecComma() ) break;
}
if( num_equived < 2 ) {
Error( EV_EQUIV_LIST );
}
if( eq_set == NULL ) {
eq_set = eq_head;
EquivSets = eq_head;
} else {
eq_set->next_eq_set = eq_head;
eq_set = eq_head;
}
ReqCloseParen();
ReqNOpn();
AdvanceITPtr();
if( !RecComma() ) break;
}
ReqEOS();
}
static void DoLoop( TYPE do_type ) {
//=====================================
// Generate code for DO statement or implied-DO.
do_entry *doptr;
uint do_size;
intstar4 incr;
intstar4 limit;
sym_id loop_ctrl;
TYPE e1_type;
uint e1_size;
itnode *e2_node;
itnode *e3_node;
bool e2_const;
doptr = CSHead->cs_info.do_parms;
do_size = CITNode->sym_ptr->u.ns.xt.size;
doptr->do_parm = CITNode->sym_ptr; // save ptr to do variable
AdvanceITPtr(); // bump past the '='
EatDoParm(); // process e1
PushOpn( CITNode );
e1_type = CITNode->typ;
e1_size = CITNode->size;
AdvanceITPtr();
if( ReqComma() ) {
EatDoParm(); // process e2
e2_const = CITNode->opn.us == USOPN_CON;
PushOpn( CITNode );
e2_node = CITNode;
AdvanceITPtr();
e3_node = NULL;
if( RecComma() ) {
EatDoParm(); // process e3
e3_node = CITNode;
if( !AError ) {
if( (CITNode->opn.us == USOPN_CON) && _IsTypeInteger( do_type ) ) {
incr = GetIntValue( CITNode );
doptr->incr_value = incr;
doptr->increment = NULL;
if( (OZOpts & OZOPT_O_FASTDO) == 0 ) {
if( e2_const ) {
limit = GetIntValue( e2_node );
if( NeedIncrement( limit, incr, do_type ) ) {
PushOpn( CITNode );
doptr->increment = StaticAlloc( do_size, do_type );
}
} else {
PushOpn( CITNode );
doptr->increment = StaticAlloc( do_size, do_type );
}
}
} else {
PushOpn( CITNode );
doptr->increment = StaticAlloc( do_size, do_type );
}
AdvanceITPtr();
}
} else {
if( _IsTypeInteger( do_type ) ) {
doptr->increment = NULL;
doptr->incr_value = 1;
if( (OZOpts & OZOPT_O_FASTDO) == 0 ) {
if( e2_const ) {
limit = GetIntValue( e2_node );
if( NeedIncrement( limit, 1, do_type ) ) {
PushConst( 1 );
doptr->increment = StaticAlloc( do_size, do_type );
}
} else {
PushConst( 1 );
doptr->increment = StaticAlloc( do_size, do_type );
}
}
} else {
PushConst( 1 );
doptr->increment = StaticAlloc( do_size, do_type );
}
}
EmitOp( FC_DO_BEGIN );
OutPtr( doptr->do_parm );
OutPtr( doptr->increment );
if( doptr->increment == NULL ) { // INTEGER do-loop with constant incr
loop_ctrl = StaticAlloc( do_size, do_type );
OutConst32( doptr->incr_value );
OutPtr( loop_ctrl );
} else {
if( _IsTypeInteger( do_type ) ) {
loop_ctrl = StaticAlloc( do_size, do_type );
} else {
loop_ctrl = StaticAlloc( sizeof( intstar4 ), FT_INTEGER );
}
doptr->iteration = loop_ctrl;
OutPtr( loop_ctrl );
if( e3_node == NULL ) {
DumpType( FT_INTEGER, TypeSize( FT_INTEGER ) );
} else {
GenType( e3_node );
}
}
GenType( e2_node );
DumpType( e1_type, e1_size );
OutU16( CSHead->branch );
OutU16( CSHead->bottom );
}
}
void CpParameter( void ) {
//=====================
// Compile PARAMETER statement.
//
// PARAMETER (P1=E1,...,Pn=En), n > 0
uint parm_size;
byte *lit;
byte *string;
int lit_len;
sym_id sym;
sym_id value_id;
TYPE typ;
byte assign_val;
ReqNOpn();
AdvanceITPtr();
ReqOpenParen();
for(;;) {
if( ReqName( NAME_VARIABLE ) ) {
sym = LkSym();
typ = sym->u.ns.u1.s.typ;
assign_val = TRUE;
if( sym->u.ns.flags & (SY_USAGE | SY_SUB_PARM | SY_IN_EC) ) {
IllName( sym );
assign_val = FALSE;
} else if( typ == FT_STRUCTURE ) {
IllType( sym );
assign_val = FALSE;
} else {
CkSymDeclared( sym );
}
AdvanceITPtr();
ReqEquSign();
parm_size = sym->u.ns.xt.size;
if( typ == FT_STRUCTURE ) {
ConstExpr( FT_NO_TYPE );
} else if( _IsTypeLogical( typ ) ) {
CLogicExpr();
} else if( typ == FT_CHAR ) {
CCharExpr();
} else {
CArithExpr();
}
if( !AError && assign_val ) {
if( typ == FT_CHAR ) {
string = (byte *)CITNode->value.cstring.strptr;
if( CITNode->size < parm_size ) {
lit = FMemAlloc( parm_size );
lit_len = CITNode->size;
memcpy( lit, string, lit_len );
memset( lit + lit_len, ' ', parm_size - lit_len );
value_id = STLit( lit, parm_size );
FMemFree( lit );
} else {
if( parm_size == 0 ) { // *(*)
parm_size = CITNode->size;
}
value_id = STLit( string, parm_size );
}
} else {
if( !_IsTypeLogical( typ ) ) {
CnvTo( CITNode, typ, parm_size );
}
value_id = STConst( &CITNode->value, typ, parm_size );
}
sym->u.ns.flags |= SY_USAGE | SY_PARAMETER | SY_TYPE;
sym->u.ns.xt.size = parm_size;
sym->u.ns.si.pc.value = value_id;
}
}
AdvanceITPtr();
if( !RecComma() ) break;
}
ReqCloseParen();
if( ReqNOpn() ) {
AdvanceITPtr();
ReqEOS();
}
}
