/// Starts a subroutine block. For this, we create a separate symbol table
/// to supplement the main one.
ParseNode KSubFunc(SymClass klass, string methodName, SymFullType returnType)
{
ProcedureParseNode node = new ProcedureParseNode();
EnsureNoLabel();
// Add the name to the global scope, ensuring it hasn't already been
// defined.
if (methodName == null) {
IdentifierToken identToken = ExpectIdentifierToken();
if (identToken == null) {
SkipToEndOfLine();
return null;
}
methodName = identToken.Name;
}
Symbol method = _globalSymbols.Get(methodName);
if (method != null && method.Defined && !method.IsExternal) {
_messages.Error(MessageCode.SUBFUNCDEFINED, String.Format("{0} already defined", methodName));
SkipToEndOfLine();
return null;
}
// Reset the COMMON indexes for this program unit
foreach (Symbol sym in _globalSymbols) {
if (sym.Type == SymType.COMMON) {
sym.CommonIndex = 0;
}
}
// New local symbol table for this block
_localSymbols = new SymbolCollection("Local");
_hasReturn = false;
// Parameter list allowed for subroutines and functions, but
// not the main program.
Collection<Symbol> parameters = null;
int alternateReturnCount = 0;
switch (klass) {
case SymClass.PROGRAM:
parameters = new Collection<Symbol>();
klass = SymClass.SUBROUTINE;
methodName = _entryPointName;
break;
case SymClass.FUNCTION:
parameters = ParseParameterDecl(_localSymbols, SymScope.PARAMETER, out alternateReturnCount);
break;
case SymClass.SUBROUTINE:
parameters = ParseParameterDecl(_localSymbols, SymScope.PARAMETER, out alternateReturnCount);
if (alternateReturnCount > 0) {
returnType = new SymFullType(SymType.INTEGER);
}
break;
}
// Don't allow alternate returns for anything except subroutines
if (alternateReturnCount > 0 && klass != SymClass.SUBROUTINE) {
_messages.Error(MessageCode.ALTRETURNNOTALLOWED, "Alternate return only permitted for subroutines");
}
// Add this method to the global symbol table now.
if (method == null) {
method = _globalSymbols.Add(methodName, new SymFullType(), klass, null, _ls.LineNumber);
}
method.Parameters = parameters;
method.Defined = true;
method.Class = klass;
if (returnType.Type != SymType.NONE) {
method.FullType = returnType;
}
if (methodName == _entryPointName) {
method.Modifier |= SymModifier.ENTRYPOINT;
_hasProgram = true;
}
// Special case for functions. Create a local symbol with the same
// name to be used for the return value.
if (klass == SymClass.FUNCTION || alternateReturnCount > 0) {
method.RetVal = _localSymbols.Add(methodName, returnType, SymClass.VAR, null, _ls.LineNumber);
method.RetVal.Modifier = SymModifier.RETVAL;
}
node.ProcedureSymbol = method;
node.LocalSymbols = _localSymbols;
node.LabelList = new Collection<ParseNode>();
_currentProcedure = node;
_currentProcedure.AlternateReturnCount = alternateReturnCount;
_initList = new CollectionParseNode();
node.InitList = _initList;
// Compile the body of the procedure
SimpleToken token = _ls.GetKeyword();
while (token.ID != TokenID.ENDOFFILE) {
if (token.ID != TokenID.EOL) {
ParseNode labelNode = CheckLabel();
if (labelNode != null) {
node.Add(labelNode);
}
if (token.ID == TokenID.KEND) {
break;
}
ParseNode lineNode = Statement(token);
if (lineNode != null) {
node.Add(MarkLine());
node.Add(lineNode);
}
ExpectEndOfLine();
}
token = _ls.GetKeyword();
}
// If we hit the end of the file first then we're missing
// a mandatory END statement.
if (token.ID != TokenID.KEND) {
_messages.Error(MessageCode.MISSINGENDSTATEMENT, "Missing END statement");
}
// Make sure we have a RETURN statement.
if (!_hasReturn) {
node.Add(new ReturnParseNode());
}
// Validate the block.
foreach (Symbol sym in _localSymbols) {
if (sym.IsLabel && !sym.Defined) {
_messages.Error(MessageCode.UNDEFINEDLABEL, sym.RefLine, String.Format("Undefined label {0}", sym.Name));
}
if (_saveAll && sym.IsLocal) {
sym.Modifier |= SymModifier.STATIC;
}
// For non-array characters, if there's no value, set the empty string
if (sym.Type == SymType.FIXEDCHAR && !sym.IsArray && !sym.Value.HasValue) {
sym.Value = new Variant(string.Empty);
}
if (!sym.IsReferenced && !(sym.Modifier.HasFlag(SymModifier.RETVAL))) {
string scopeName = (sym.IsParameter) ? "parameter" : (sym.IsLabel) ? "label" : "variable";
_messages.Warning(MessageCode.UNUSEDVARIABLE,
3,
sym.RefLine,
String.Format("Unused {0} {1} in function", scopeName, sym.Name));
}
}
ValidateBlock(0, node);
_state = BlockState.SPECIFICATION;
return node;
}
/// COMMON keyword
/// Syntax: COMMON ident [,ident]
ParseNode KCommon()
{
SymFullType fullType = new SymFullType(SymType.NONE);
List<Symbol> commonSymbols = null;
bool isNewBlock = true;
Symbol symCommon = null;
do {
SimpleToken token = _ls.GetToken();
string name = "_COMMON";
if (token.ID == TokenID.DIVIDE) {
IdentifierToken identToken = ExpectIdentifierToken();
if (identToken == null) {
SkipToEndOfLine();
return null;
}
name = identToken.Name;
isNewBlock = true;
ExpectToken(TokenID.DIVIDE);
} else if (token.ID == TokenID.CONCAT) {
name = "_COMMON";
isNewBlock = true;
} else {
_ls.BackToken();
}
if (isNewBlock) {
symCommon = _globalSymbols.Get(name);
if (symCommon == null) {
symCommon = _globalSymbols.Add(name, new SymFullType(SymType.COMMON), SymClass.COMMON, null, _ls.LineNumber);
commonSymbols = new List<Symbol>();
symCommon.Info = commonSymbols;
symCommon.CommonIndex = 0;
}
commonSymbols = (List<Symbol>)symCommon.Info;
isNewBlock = false;
}
Symbol sym = ParseIdentifierDeclaration(fullType);
if (sym != null) {
if (sym.IsInCommon) {
_messages.Error(MessageCode.ALREADYINCOMMON, string.Format("{0} is already in a COMMON block", sym.Name));
} else {
sym.CommonIndex = symCommon.CommonIndex;
sym.Common = symCommon;
sym.IsReferenced = true;
// Symbols in the primary COMMON block need to be static so
// they can be referenced from sub-programs
if (sym.CommonIndex < commonSymbols.Count) {
Symbol symInCommon = commonSymbols[sym.CommonIndex];
sym.FullType = symInCommon.FullType;
} else {
sym.Modifier |= SymModifier.STATIC;
commonSymbols.Add(sym);
}
symCommon.CommonIndex += 1;
}
SkipToken(TokenID.COMMA);
}
} while (!IsAtEndOfLine());
return null;
}
/// IMPLICIT keyword
/// Syntax: IMPLICIT type (c1-c2) - all identifiers beginning with the letter or letter range c1 to c2
/// are implicitly typed with the given type.
ParseNode KImplicit()
{
SimpleToken token;
EnsureNoLabel();
do {
token = _ls.GetKeyword();
switch (token.ID) {
case TokenID.KINTEGER:
case TokenID.KDPRECISION:
case TokenID.KCHARACTER:
case TokenID.KLOGICAL:
case TokenID.KCOMPLEX:
case TokenID.KREAL: {
SymFullType fullType = new SymFullType(TokenToType(token.ID));
fullType.Width = ParseTypeWidth(1);
ExpectToken(TokenID.LPAREN);
do {
IdentifierToken identToken = ExpectIdentifierToken();
if (identToken != null) {
char ch1 = identToken.Name[0];
char ch2 = ch1;
if (ch1 < 'A' || ch1 > 'Z') {
_messages.Error(MessageCode.IMPLICITSINGLECHAR, "IMPLICIT must have a single character");
}
token = _ls.GetToken();
if (token.ID == TokenID.MINUS) {
identToken = ExpectIdentifierToken();
if (identToken != null) {
ch2 = identToken.Name[0];
if (ch2 < 'A' || ch2 > 'Z') {
_messages.Error(MessageCode.IMPLICITSINGLECHAR, "IMPLICIT must have a single character");
}
if (ch2 < ch1) {
_messages.Error(MessageCode.IMPLICITRANGEERROR, "IMPLICIT character range out of sequence");
}
token = _ls.GetToken();
}
}
// Check for duplicate definitions
for (char chTmp = ch1; chTmp <= ch2; ++chTmp) {
if (_localSymbols.IsImplicitSet(chTmp)) {
_messages.Error(MessageCode.IMPLICITCHAREXISTS, String.Format("Character {0} already specified in an IMPLICIT", chTmp));
}
_localSymbols.SetImplicit(chTmp);
}
_localSymbols.Implicit(ch1, ch2, fullType);
}
} while (token.ID == TokenID.COMMA);
_ls.BackToken();
ExpectToken(TokenID.RPAREN);
_state = BlockState.IMPLICIT;
break;
}
default:
_messages.Error(MessageCode.IMPLICITSYNTAXERROR, "Syntax error in IMPLICIT statement");
break;
}
token = _ls.GetToken();
} while (token.ID == TokenID.COMMA);
_ls.BackToken();
return null;
}
/// EXTERNAL keyword
/// Specifies the given names to be an external function or subroutine.
/// as arguments.
ParseNode KExternal()
{
SimpleToken token;
EnsureNoLabel();
do {
IdentifierToken identToken = ExpectIdentifierToken();
if (identToken != null) {
Symbol sym = _localSymbols.Get(identToken.Name);
// External scope being given to a dummy argument
if (sym != null && sym.IsParameter) {
sym.Class = SymClass.FUNCTION;
} else {
SymFullType fullType = new SymFullType();
if (sym != null) {
fullType = sym.FullType;
_localSymbols.Remove(sym);
}
sym = _globalSymbols.Add(identToken.Name, fullType, SymClass.FUNCTION, null, _ls.LineNumber);
sym.Modifier |= SymModifier.EXTERNAL;
sym.Defined = true;
}
sym.Linkage = SymLinkage.BYVAL;
}
token = _ls.GetToken();
} while (token.ID == TokenID.COMMA);
_ls.BackToken();
return null;
}
/// DIMENSION keyword
/// Used to apply a dimension to a prior declared variable. Can be used to
/// declare a variable assuming implicit type is permitted for the name.
ParseNode KDimension()
{
SymFullType fullType = new SymFullType(SymType.NONE);
SimpleToken token;
do {
Symbol sym = ParseIdentifierDeclaration(fullType);
if (sym != null) {
if (sym.Dimensions == null || sym.Dimensions.Count == 0) {
_messages.Error(MessageCode.MISSINGARRAYDIMENSIONS, "Array dimensions expected");
}
sym.Defined = false;
}
token = _ls.GetToken();
} while (token.ID == TokenID.COMMA);
_ls.BackToken();
return null;
}
/// Handle a declaration statement of the specified type.
ParseNode KDeclaration(SymType type)
{
SymFullType fullType = new SymFullType(type);
SimpleToken token;
if (Symbol.IsCharType(type)) {
fullType.Width = ParseTypeWidth(0);
}
// Could be a function declaration preceded by type?
if (_ls.PeekKeyword() == TokenID.KFUNCTION) {
_ls.GetToken();
return KSubFunc(SymClass.FUNCTION, null, fullType);
}
do {
Symbol sym = ParseIdentifierDeclaration(fullType);
if (sym != null) {
if (sym.Defined) {
_messages.Error(MessageCode.IDENTIFIERREDEFINITION, String.Format("Identifier {0} already declared", sym.Name));
}
if (sym.IsParameter) {
if (!sym.IsArray && !sym.IsMethod && sym.IsValueType) {
sym.Linkage = SymLinkage.BYREF;
} else {
sym.Linkage = SymLinkage.BYVAL;
}
}
sym.Defined = true;
}
token = _ls.GetToken();
} while (token.ID == TokenID.COMMA);
_ls.BackToken();
return null;
}
// Parse an identifier declaration
Symbol ParseIdentifierDeclaration(SymFullType fullType)
{
IdentifierToken identToken = ExpectIdentifierToken();
Symbol sym = null;
if (identToken != null) {
// Ban any conflict with PROGRAM name or the current function
Symbol globalSym = _globalSymbols.Get(identToken.Name);
if (globalSym != null && globalSym.Type == SymType.PROGRAM) {
_messages.Error(MessageCode.IDENTIFIERISGLOBAL, String.Format("Identifier {0} already has global declaration", identToken.Name));
SkipToEndOfLine();
return null;
}
// Now check the local program unit
sym = _localSymbols.Get(identToken.Name);
// Handle array syntax and build a list of dimensions
Collection<SymDimension> dimensions = ParseArrayDimensions();
if (dimensions == null) {
return null;
}
// If this is the main program, all dimensions must be constant
if (_currentProcedure != null && _currentProcedure.IsMainProgram) {
foreach (SymDimension dim in dimensions) {
if (dim.Size < 0) {
_messages.Error(MessageCode.ARRAYILLEGALBOUNDS, "Array dimensions must be constant");
break;
}
}
}
// Check for width specifier. This always follows array bounds and if one is
// specified, it only applies to this identifier so the original width, if any,
// must be preserved.
SymFullType thisFullType = new SymFullType();
int width = fullType.Width;
if (width == 0) {
SymFullType impliedFullType = _localSymbols.ImplicitTypeForCharacter(identToken.Name[0]);
width = impliedFullType.Width;
}
thisFullType.Type = fullType.Type;
thisFullType.Width = ParseTypeWidth(width);
// Indicate this symbol is explicitly declared
if (sym == null) {
if (identToken.Name.Length > 6 && _opts.F77) {
_messages.Error(MessageCode.IDENTIFIERTOOLONG, String.Format("Identifier {0} length too long", identToken.Name));
}
sym = _localSymbols.Add(identToken.Name, thisFullType, SymClass.VAR, dimensions, _ls.LineNumber);
} else {
if (fullType.Type != SymType.NONE) {
sym.FullType = thisFullType;
}
if (dimensions.Count > 0) {
sym.Dimensions = dimensions;
}
}
// If this is applying type to a function, update the function too
if (globalSym != null && sym == globalSym.RetVal) {
globalSym.FullType = thisFullType;
}
// BUGBUG: This should be done in the Symbols class when the
// identifier becomes an array.
if (sym.IsArray) {
sym.Linkage = SymLinkage.BYVAL;
sym.Modifier |= SymModifier.FLATARRAY; // FORTRAN always uses flat arrays
}
}
return sym;
}