void CpElseIf(void) {
//==================
// Process an ELSEIF statement.
if( ( CSHead->typ == CS_IF ) || ( CSHead->typ == CS_ELSEIF ) ) {
GBranch( CSHead->bottom );
GLabel( CSHead->branch );
FreeLabel( CSHead->branch );
CSHead->typ = CS_ELSEIF;
CSHead->branch = NextLabel();
CSHead->block = ++BlockNum;
} else if( CSHead->typ == CS_ELSE ) {
Error( IF_ELSE_LAST );
} else {
Match();
}
CSCond( CSHead->branch );
if( RecKeyWord( "THEN" ) ) {
AdvanceITPtr();
ReqEOS();
} else {
Error( IF_NO_THEN );
}
}
void CpPrint( void ) {
//=================
// Compile PRINT statement.
itnode *cit;
InitIO();
Form();
if( !RecEOS() ) {
ReqComma();
if( RecNOpn() ) {
cit = CITNode;
AdvanceITPtr();
if( RecEOS() ) {
CITNode = cit;
Error( SX_SURP_OPR );
}
CITNode = cit;
}
}
IOList();
ReqEOS();
FiniIO();
}
void CpReturn( void )
{
if( !(ProgSw & PS_IN_SUBPROGRAM) ) {
Extension( RE_IN_PROGRAM );
}
CkRemBlock();
if( RecNOpn() && RecNextOpr( OPR_TRM ) ) {
if( ( ( SubProgId->u.ns.flags & SY_CLASS ) == SY_SUBPROGRAM ) &&
( ( SubProgId->u.ns.flags & SY_SUBPROG_TYPE ) == SY_SUBROUTINE ) ) {
GNullRetIdx();
}
} else {
IntSubExpr();
if( ( ( SubProgId->u.ns.flags & SY_CLASS ) == SY_SUBPROGRAM ) &&
( ( SubProgId->u.ns.flags & SY_SUBPROG_TYPE ) == SY_SUBROUTINE ) ) {
GRetIdx();
} else {
Error( RE_ALT_IN_SUBROUTINE );
}
}
AdvanceITPtr();
ReqEOS();
GGotoEpilog();
Remember.transfer = true;
Remember.stop_or_return = true;
}
void EndOfStatement( void ) {
//========================
ReqNOpn();
AdvanceITPtr();
ReqEOS();
}
void CpRead( void ) {
//================
// Compile READ statement.
itnode *cit;
Remember.read = true;
InitIO();
cit = CITNode;
AdvanceITPtr();
if( RecOpenParen() && ReadKWList() ) {
KeywordList();
ReqCloseParen();
} else {
CITNode = cit;
Form();
if( !RecEOS() ) {
ReqComma();
}
}
if( !Remember.end_equals ) {
GNullEofStmt();
}
IOList();
ReqEOS();
FiniIO();
}
void Function( TYPE typ, uint size, bool len_spec )
{
// Compile [type] [*len] FUNCTION NAME[*len] ([d,d,...])
// \ /
// Already scanned
//
unsigned_16 flags;
entry_pt *entry;
flags = SY_USAGE | SY_SUBPROGRAM | SY_PENTRY | SY_FUNCTION;
if( typ == FT_NO_TYPE ) {
typ = ImplType( *(CITNode->opnd) );
} else {
flags |= SY_TYPE;
}
CkSubEnd();
ProgSw |= PS_IN_SUBPROGRAM;
if( ReqName( NAME_FUNCTION ) ) {
entry = SubProgName( typ, flags, size, len_spec );
STFnShadow( SubProgId );
if( ReqOpenParen() ) {
ParmList( false, entry );
}
ReqCloseParen();
ReqNOpn();
AdvanceITPtr();
ReqEOS();
} else {
// We still want to start a subprogram even though there is no name.
SubProgId = LkProgram(); // use default name
GSegLabel();
}
BIStartSubroutine();
}
void CpRemBlock( void )
{
sym_id rb;
if( EmptyCSList() == FALSE ) {
StmtErr( SP_BLK_IN_STRUCTURE );
}
AddCSNode( CS_REMOTEBLOCK );
CSHead->bottom = NextLabel();
CSHead->branch = NextLabel();
GBranch( CSHead->branch );
if( BlockName( SY_RB_DEFINED ) ) {
rb = CITNode->sym_ptr;
if( ( rb->ns.flags & SY_REFERENCED ) == 0 ) {
rb->ns.si.rb.ref_count = 0;
}
rb->ns.si.rb.ref_count++;
CSHead->cs_info.rb = rb;
GStartBlock();
BIStartRBorEP( rb );
}
AdvanceITPtr();
ReqEOS();
StNumbers.in_remote = TRUE;
ClearRem();
}
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 CpProgram( void )
{
CkSubEnd();
if( ReqName( NAME_PROGRAM ) ) {
SubProgId = LkProgram(); // use default name
} else {
SubProgId = LkProgram(); // use default name
}
StartProg();
AdvanceITPtr();
ReqEOS();
}
void CpEnd(void) {
//===============
LFSkip();
if( RecNOpn() ) {
ProgSw |= PS_END_OF_SUBPROG;
AdvanceITPtr();
Remember.endstmt = true;
ReqEOS();
} else {
BadStmt();
}
}
static void JustList( void ) {
//==========================
// The io statement must have a keyword list in brackets.
InitIO();
if( RecTrmOpr() && RecNOpn() ) {
AdvanceITPtr();
}
if( ReqOpenParen() ) {
DoKWList();
}
ReqEOS();
GStartIO();
FiniIO();
}
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();
}
}
void CpWrite( void ) {
//=================
// Compile WRITE statement.
InitIO();
if( RecTrmOpr() && RecNOpn() ) {
AdvanceITPtr();
}
if( ReqOpenParen() ) {
KeywordList();
ReqCloseParen();
IOList();
}
ReqEOS();
FiniIO();
}
void CpEntry( void )
{
entry_pt *entry;
bool in_subr;
sym_id sym;
if( ( ProgSw & PS_IN_SUBPROGRAM ) == 0 ) {
StmtErr( SR_ILL_IN_PROG );
}
if( !EmptyCSList() ) {
Error( EY_NOT_IN_CS );
}
if( ReqName( NAME_FUNCTION ) ) {
in_subr = (SubProgId->u.ns.flags & SY_SUBPROG_TYPE) == SY_SUBROUTINE;
sym = LkSym();
if( ( sym->u.ns.flags & (SY_USAGE|SY_SUB_PARM|SY_IN_EC|SY_SAVED) ) ||
( in_subr && (sym->u.ns.flags & SY_TYPE) ) ) {
IllName( sym );
} else {
sym->u.ns.u1.s.typ = CITNode->typ;
sym->u.ns.flags &= SY_TYPE;
if( in_subr ) {
sym->u.ns.flags |= SY_USAGE | SY_SUBPROGRAM | SY_SENTRY |
SY_SUBROUTINE | SY_REFERENCED;
} else {
sym->u.ns.flags |= SY_USAGE | SY_SUBPROGRAM | SY_SENTRY |
SY_FUNCTION;
}
STFnShadow( sym );
entry = AddEntryPt( sym );
AdvanceITPtr();
if( Options & OPT_TRACE ) {
GSetSrcLine();
}
if( RecOpenParen() ) {
ParmList( in_subr, entry );
ReqCloseParen();
ReqNOpn();
AdvanceITPtr();
}
BIStartRBorEP( sym );
ReqEOS();
}
}
SgmtSw &= ~SG_PROLOG_DONE; // indicate we need prologue
}
static void UnitOrList( void ) {
//============================
// The io statement can have a unit id by itself or have a keyword list
// in brackets.
InitIO();
if( RecNextOpr( OPR_LBR ) && RecNOpn() ) {
AdvanceITPtr();
DoKWList();
} else {
Permission( IO_UNIT ); // remembers unit= specified
Unit();
AdvanceITPtr();
}
ReqEOS();
GStartIO();
FiniIO();
}
void CpExecute( void )
{
sym_id rb;
if( StNumbers.in_remote ) {
CkRemBlkRec();
}
if( BlockName( 0 ) ) {
rb = CITNode->sym_ptr;
if( ( rb->ns.flags & ( SY_RB_DEFINED | SY_REFERENCED ) ) == 0 ) {
rb->ns.si.rb.ref_count = 0;
}
rb->ns.si.rb.ref_count++;
BIOutSymbol( rb ); // reference and or declare the sucker
rb->ns.flags |= SY_REFERENCED;
GExecute();
}
AdvanceITPtr();
ReqEOS();
}
void CpInclude(void) {
//===================
// Process INCLUDE statement.
// INCLUDE 'file-name'
char *lit;
StmtExtension( SP_STRUCTURED_EXT );
if( RecLiteral() ) {
lit = MkNodeStr( CITNode );
AdvanceITPtr();
if( ReqEOS() ) {
Include( lit );
ComRead();
}
FrNodeStr( lit );
} else {
Error( SX_EXPECT_CHAR_CONST );
}
}
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 CpSubroutine( void )
{
entry_pt *entry;
CkSubEnd();
ProgSw |= PS_IN_SUBPROGRAM;
if( ReqName( NAME_SUBROUTINE ) ) {
entry = SubProgName( FT_NO_TYPE, SY_USAGE | SY_SUBPROGRAM | SY_PENTRY |
SY_SUBROUTINE | SY_REFERENCED, 0, true );
if( RecOpenParen() ) {
ParmList( true, entry );
ReqCloseParen();
ReqNOpn();
AdvanceITPtr();
}
ReqEOS();
} else {
// We still want to start a subprogram even though there is no name.
SubProgId = LkProgram(); // use default name
GSegLabel();
}
BIStartSubroutine();
}
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 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();
}
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();
}
}