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();
}
static bool BlockName( unsigned_16 rb_defined )
{
sym_id sym_ptr;
unsigned_16 flag_mask;
bool rb_name;
CSExtn();
rb_name = FALSE;
if( ReqName( NAME_REM_BLOCK ) ) {
sym_ptr = LkSym();
if( ( sym_ptr->ns.flags & ~SY_REFERENCED ) == 0 ) {
sym_ptr->ns.si.rb.entry = NextLabel();
sym_ptr->ns.flags = RB_FLAGS;
}
flag_mask = (unsigned_16)~( SY_RB_DEFINED | SY_REFERENCED );
if( ( ( sym_ptr->ns.flags & flag_mask ) == RB_FLAGS ) &&
( ( sym_ptr->ns.flags & rb_defined ) == 0 ) ) {
sym_ptr->ns.flags |= rb_defined;
rb_name = TRUE;
} else {
IllName( sym_ptr );
}
}
return( rb_name );
}
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 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();
}
static void VarList( void ) {
//=========================
// Process one variable list in a DATA statement.
OPR last_opr;
OPR opr;
int do_level;
itnode *last_node;
do_level = 0;
last_opr = FindSlash( &last_node );
while( CITNode != last_node ) {
if( AError )
break;
if( RecTrmOpr() && ( CITNode != ITHead ) ) {
--do_level;
FinishImpDo();
} else if( StartImpDo() ) {
++do_level;
} else if( ReqName( NAME_VAR_OR_ARR ) ) {
InitVar = LkSym();
if( InitVar->u.ns.u1.s.typ == FT_STRUCTURE ) {
// make sure structure size is calculated - normally
// structure size is calculated by StructResolve() which
// is not called until the first executable statement
CalcStructSize( InitVar->u.ns.xt.sym_record );
}
CkFlags();
opr = CITNode->opr;
ProcDataExpr();
CITNode->opr = opr;
ListItem();
if( !RecTrmOpr() ) {
ReqComma();
}
} else {
AdvanceITPtr();
AError = true;
break;
}
}
if( AError ) {
while( do_level != 0 ) { // clean up hanging do entrys
TermDo();
--do_level;
}
} else {
CITNode->opr = last_opr;
ReqDiv();
}
}
void CpCall(void) {
//================
itnode *next;
unsigned_16 sp_type;
next = CITNode->link;
if( next->opr == OPR_TRM ) {
ASType = AST_CNA; // call with no parameter list
} else if( ( next->opr == OPR_LBR ) &&
( next->opn.ds == DSOPN_PHI ) &&
( next->link->opr == OPR_RBR ) &&
( next->link->opn.ds == DSOPN_PHI ) &&
( next->link->link->opr == OPR_TRM ) ) {
next->opr = OPR_TRM; // make CALL SAM() same as CALL SAM
ASType = AST_CNA; // call with no parameter list
} else {
ReqNextOpr( OPR_LBR, SX_SURP_OPR );
if( ( SPtr1 != NULL ) && ( SPtr1->link->opr != OPR_TRM ) ) {
Error( SX_JUNK_AFTER_RBR ); // ignore anything after
SPtr1->link->opr = OPR_TRM; // closing parenthesis
}
ASType = AST_OFF;
}
if( ReqName( NAME_SUBROUTINE ) ) {
LkSym();
if( ClassIs( SY_SUBPROGRAM ) ) {
sp_type = CITNode->flags & SY_SUBPROG_TYPE;
if( sp_type == SY_SUBROUTINE ) {
ASType |= AST_ALT;
Arith();
} else if( sp_type == SY_FUNCTION ) {
Extension( SR_FUNC_AS_SUB );
Arith();
} else if( sp_type == 0 ) {
ArithNewSubr();
} else {
Error( SR_NO_SUBRTN_NAME );
}
} else {
if( CITNode->flags & SY_USAGE ) {
Error( SR_NO_SUBRTN_NAME );
} else if( CITNode->flags & SY_SAVED ) {
Error( SA_SAVED );
} else {
ArithNewSubr();
}
}
}
}
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
}
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 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 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 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();
}
}
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();
}
