MODULE FoxSemanticChecker;
IMPORT D := Debugging, Basic := FoxBasic, Scanner := FoxScanner, SyntaxTree := FoxSyntaxTree,
Diagnostics, Global := FoxGlobal, Printout:= FoxPrintout, Formats := FoxFormats, ActiveCells := FoxActiveCells, SYSTEM, Machine,Strings;
CONST
Trace = FALSE;
Infinity = MAX(LONGINT);
InvalidPosition* = Diagnostics.Invalid;
MaxTensorIndexOperatorSize = 4;
UndefinedPhase = 0; DeclarationPhase=1; ImplementationPhase=2;
TYPE
FileName=ARRAY 256 OF CHAR;
LateFix= POINTER TO RECORD
p: ANY; scope: SyntaxTree.Scope;
next: LateFix;
END;
LateFixList = OBJECT
VAR first,last: LateFix;
PROCEDURE & Init;
BEGIN first := NIL; last := NIL;
END Init;
PROCEDURE Get(VAR scope: SyntaxTree.Scope): ANY;
VAR p: ANY;
BEGIN
IF first # NIL THEN p := first.p; scope := first.scope; first := first.next ELSE p := NIL; END;
IF first = NIL THEN last := NIL END;
RETURN p;
END Get;
PROCEDURE Add(p: ANY; scope: SyntaxTree.Scope);
VAR next: LateFix;
BEGIN
ASSERT(scope # NIL);
NEW(next); next.p := p; next.scope := scope;
next.next := NIL;
IF first = NIL THEN first := next; last := next;
ELSE last.next := next; last := next
END;
END Add;
END LateFixList;
WithEntry = POINTER TO RECORD
previous: WithEntry;
symbol: SyntaxTree.Symbol;
type: SyntaxTree.Type;
END;
Checker*= OBJECT (SyntaxTree.Visitor)
VAR
module: SyntaxTree.Module;
diagnostics: Diagnostics.Diagnostics;
useDarwinCCalls: BOOLEAN;
error-: BOOLEAN;
VerboseErrorMessage: BOOLEAN;
typeFixes, pointerFixes: LateFixList;
importCache-: SyntaxTree.ModuleScope;
arrayBaseImported: BOOLEAN;
phase: LONGINT;
system-: Global.System;
symbolFileFormat-: Formats.SymbolFileFormat;
resolvedType: SyntaxTree.Type;
resolvedExpression: SyntaxTree.Expression;
resolvedStatement: SyntaxTree.Statement;
currentScope-: SyntaxTree.Scope;
currentIsRealtime: BOOLEAN;
currentIsUnreachable: BOOLEAN;
currentIsCellNet: BOOLEAN;
currentIsBodyProcedure: BOOLEAN;
currentIsExclusive: BOOLEAN;
global: SyntaxTree.ModuleScope;
withEntries: WithEntry;
flagExpressions: ARRAY 32 OF SyntaxTree.Expression;
activeCellsStatement: BOOLEAN;
activeCellsSpecification: ActiveCells.Specification;
indexCounter : LONGINT;
PROCEDURE &InitChecker*(diagnostics: Diagnostics.Diagnostics; verboseErrorMessage,useDarwinCCalls: BOOLEAN; system: Global.System; symbolFileFormat: Formats.SymbolFileFormat; activeCellsSpecification: ActiveCells.Specification; VAR importCache: SyntaxTree.ModuleScope);
BEGIN
SELF.diagnostics := diagnostics;
SELF.useDarwinCCalls := useDarwinCCalls;
SELF.system := system;
SELF.symbolFileFormat := symbolFileFormat;
SELF.activeCellsSpecification := activeCellsSpecification;
error := FALSE;
NEW(typeFixes);
NEW(pointerFixes);
resolvedType := NIL;
resolvedExpression := NIL;
resolvedStatement := NIL;
currentScope := NIL;
IF importCache = NIL THEN importCache := SyntaxTree.NewModuleScope() END;
SELF.importCache := importCache;
arrayBaseImported := FALSE;
SELF.VerboseErrorMessage := verboseErrorMessage;
global := NIL;
phase := UndefinedPhase;
currentIsRealtime := FALSE;
currentIsUnreachable := FALSE;
currentIsCellNet := FALSE;
currentIsBodyProcedure := FALSE;
currentIsExclusive := FALSE;
withEntries := NIL;
indexCounter := 0;
END InitChecker;
PROCEDURE GetIndex(): LONGINT;
BEGIN
INC(indexCounter); RETURN indexCounter;
END GetIndex;
PROCEDURE Error(position: LONGINT; code: LONGINT; CONST message: ARRAY OF CHAR);
VAR errorMessage: ARRAY 256 OF CHAR; errModule: SyntaxTree.Module;
BEGIN
IF diagnostics # NIL THEN
Basic.GetErrorMessage(code,message,errorMessage);
ASSERT(currentScope # NIL);
IF module # NIL THEN errModule := module ELSE errModule := currentScope.ownerModule END;
diagnostics.Error(errModule.sourceName, position, code, errorMessage);
END;
error := TRUE;
END Error;
PROCEDURE Warning(position: LONGINT; CONST message: ARRAY OF CHAR);
VAR errModule: SyntaxTree.Module;
BEGIN
IF diagnostics # NIL THEN
IF module # NIL THEN errModule := module ELSE errModule := currentScope.ownerModule END;
diagnostics.Warning(errModule.sourceName, position, Diagnostics.Invalid, message);
END;
END Warning;
PROCEDURE ErrorSS(position: LONGINT; CONST msg,msg2: ARRAY OF CHAR);
VAR errorMessage: ARRAY 256 OF CHAR;
BEGIN
IF diagnostics # NIL THEN
Basic.Concat(errorMessage,msg," ", msg2);
diagnostics.Error(currentScope.ownerModule.sourceName, position, Diagnostics.Invalid, errorMessage);
END;
error := TRUE;
END ErrorSS;
PROCEDURE Find(inScope: SyntaxTree.Scope; name: SyntaxTree.Identifier; traverse: BOOLEAN): SyntaxTree.Symbol;
VAR
scope,baseScope: SyntaxTree.Scope;
symbol: SyntaxTree.Symbol;
ownerRecord,base: SyntaxTree.RecordType;
BEGIN
scope := inScope;
WHILE (scope # NIL) & (symbol = NIL) DO
symbol := scope.FindSymbol(name);
WHILE (symbol # NIL) & (symbol.scope.ownerModule # currentScope.ownerModule) & (symbol.access * SyntaxTree.Public = {}) DO
symbol.MarkUsed;
IF (symbol.scope IS SyntaxTree.RecordScope) THEN
ownerRecord := symbol.scope(SyntaxTree.RecordScope).ownerRecord;
base := RecordBase(ownerRecord);
IF (base # NIL) THEN
baseScope := base.recordScope;
symbol := Find(baseScope,name,FALSE);
ELSE
symbol := NIL;
END;
ELSE
symbol := NIL;
END;
END;
IF traverse THEN scope := scope.outerScope ELSE scope := NIL END;
END;
IF (symbol # NIL) THEN
IF ~(SyntaxTree.Resolved IN symbol.state) THEN
ASSERT(phase = DeclarationPhase);
ResolveSymbol(symbol)
END;
symbol.MarkUsed;
END;
RETURN symbol
END Find;
PROCEDURE ResolveNamedType(qualifiedIdentifier: SyntaxTree.QualifiedIdentifier; VAR typeDeclaration: SyntaxTree.TypeDeclaration): SyntaxTree.Type;
VAR prevScope: SyntaxTree.Scope; symbol: SyntaxTree.Symbol; result:SyntaxTree.Type;
BEGIN
result := NIL;
prevScope := currentScope;
IF (qualifiedIdentifier.prefix # SyntaxTree.invalidIdentifier) THEN
symbol := Find(currentScope,qualifiedIdentifier.prefix,TRUE);
IF (symbol # NIL) & (symbol IS SyntaxTree.Import) THEN
IF symbol(SyntaxTree.Import).module = NIL THEN
Error(qualifiedIdentifier.position,Diagnostics.Invalid,"module not loaded");
result := SyntaxTree.invalidType;
symbol := NIL;
ELSE
currentScope := symbol(SyntaxTree.Import).module.moduleScope;
symbol := Find(currentScope,qualifiedIdentifier.suffix,FALSE);
IF (symbol = NIL) OR (symbol.access * SyntaxTree.Public = {}) THEN Error(qualifiedIdentifier.position,Diagnostics.Invalid,"undeclared identifier (prefix-suffix)") END;
END;
ELSE
Error(qualifiedIdentifier.position,Diagnostics.Invalid,"prefix does not denote a module name");
symbol := NIL;
END;
ELSE
symbol := Find(currentScope,qualifiedIdentifier.suffix,TRUE);
IF symbol = NIL THEN
Error(qualifiedIdentifier.position,Diagnostics.Invalid,"undeclared identifier (qualident suffix)");
IF VerboseErrorMessage THEN
Printout.Info("Qualident",qualifiedIdentifier);
Printout.Info("in scope",currentScope) ;
END;
END;
END;
IF symbol = NIL THEN
typeDeclaration := NIL;
result := SyntaxTree.invalidType;
ELSIF ~(symbol IS SyntaxTree.TypeDeclaration) THEN
Error(qualifiedIdentifier.position,Diagnostics.Invalid,"symbol does not denote a type");
typeDeclaration := NIL;
result := SyntaxTree.invalidType;
ELSE
currentScope := symbol.scope;
typeDeclaration := symbol(SyntaxTree.TypeDeclaration);
result := ResolveType(typeDeclaration.declaredType);
symbol.MarkUsed;
ASSERT(result # NIL);
END;
currentScope := prevScope;
RETURN result
END ResolveNamedType;
PROCEDURE TypeNeedsResolution(x: SyntaxTree.Type): BOOLEAN;
VAR result: BOOLEAN;
BEGIN
IF SyntaxTree.Resolved IN x.state THEN
result := FALSE
ELSIF SyntaxTree.BeingResolved IN x.state THEN
Error(x.position,Diagnostics.Invalid,"cyclic definition");
result := FALSE;
ELSE
result := TRUE;
x.SetState(SyntaxTree.BeingResolved)
END;
RETURN result
END TypeNeedsResolution;
PROCEDURE ResolvedType(x: SyntaxTree.Type): SyntaxTree.Type;
BEGIN
IF SyntaxTree.Resolved IN x.state THEN
RETURN x
ELSE
RETURN SyntaxTree.invalidType
END;
END ResolvedType;
PROCEDURE VisitType(x: SyntaxTree.Type);
BEGIN
ASSERT(x = SyntaxTree.invalidType);
END VisitType;
PROCEDURE VisitBasicType(x: SyntaxTree.BasicType);
BEGIN
IF TypeNeedsResolution(x) THEN
x.SetState(SyntaxTree.Resolved);
END;
resolvedType := ResolvedType(x)
END VisitBasicType;
PROCEDURE VisitByteType(x: SyntaxTree.ByteType);
BEGIN
VisitBasicType(x);
END VisitByteType;
PROCEDURE VisitCharacterType(x: SyntaxTree.CharacterType);
BEGIN
VisitBasicType(x);
END VisitCharacterType;
PROCEDURE VisitBooleanType(x: SyntaxTree.BooleanType);
BEGIN
VisitBasicType(x);
END VisitBooleanType;
PROCEDURE VisitSetType(x: SyntaxTree.SetType);
BEGIN
VisitBasicType(x);
END VisitSetType;
PROCEDURE VisitAddressType(x: SyntaxTree.AddressType);
BEGIN
VisitBasicType(x);
END VisitAddressType;
PROCEDURE VisitSizeType(x: SyntaxTree.SizeType);
BEGIN
VisitBasicType(x);
END VisitSizeType;
PROCEDURE VisitAnyType(x: SyntaxTree.AnyType);
BEGIN
VisitBasicType(x);
END VisitAnyType;
PROCEDURE VisitObjectType(x: SyntaxTree.ObjectType);
BEGIN
VisitBasicType(x);
END VisitObjectType;
PROCEDURE VisitNilType(x: SyntaxTree.NilType);
BEGIN
VisitBasicType(x);
END VisitNilType;
PROCEDURE VisitIntegerType(x: SyntaxTree.IntegerType);
BEGIN
VisitBasicType(x);
END VisitIntegerType;
PROCEDURE VisitFloatType(x: SyntaxTree.FloatType);
BEGIN
VisitBasicType(x);
END VisitFloatType;
PROCEDURE VisitComplexType(x: SyntaxTree.ComplexType);
BEGIN
VisitBasicType(x);
END VisitComplexType;
PROCEDURE VisitStringType(x: SyntaxTree.StringType);
BEGIN
IF TypeNeedsResolution(x) THEN
x.SetState(SyntaxTree.Resolved);
END;
resolvedType := ResolvedType(x)
END VisitStringType;
PROCEDURE CheckEnumerationScope(x: SyntaxTree.EnumerationScope; VAR highest: LONGINT);
VAR e: SyntaxTree.Constant; value: SyntaxTree.Expression; nextHighest: LONGINT; prevScope: SyntaxTree.Scope;
BEGIN
prevScope := currentScope;
currentScope := x;
e := x.firstConstant;
WHILE (e # NIL) DO
Register(e,x,FALSE);
IF SymbolNeedsResolution(e) THEN
IF e.value # NIL THEN
value := ConstantExpression(e.value);
value := NewConversion(e.position,value,x.ownerEnumeration,NIL);
ELSE
value := SyntaxTree.NewEnumerationValue(e.position,highest+1);
value.SetType(x.ownerEnumeration);
END;
IF (value.resolved # NIL) & (value.resolved IS SyntaxTree.EnumerationValue) THEN
nextHighest := value.resolved(SyntaxTree.EnumerationValue).value;
IF nextHighest > highest THEN highest := nextHighest END;
END;
e.SetValue(value);
CheckSymbolVisibility(e);
e.SetType(x.ownerEnumeration);
e.SetState(SyntaxTree.Resolved);
END;
e := e.nextConstant;
END;
currentScope := prevScope;
END CheckEnumerationScope;
PROCEDURE VisitEnumerationType(x: SyntaxTree.EnumerationType);
VAR position: LONGINT; baseScope: SyntaxTree.EnumerationScope; baseType,resolved: SyntaxTree.Type; enumerationBase: SyntaxTree.EnumerationType;
lowest, highest: LONGINT;
BEGIN
IF TypeNeedsResolution(x) THEN
IF x.enumerationBase # NIL THEN
position := x.enumerationBase.position;
baseType := ResolveType(x.enumerationBase);
resolved := baseType.resolved;
baseScope := NIL;
IF resolved = SyntaxTree.invalidType THEN
ELSIF ~(resolved IS SyntaxTree.EnumerationType) THEN
Error(position,Diagnostics.Invalid,"base type is no enumeration type");
ELSE
enumerationBase := resolved(SyntaxTree.EnumerationType);
lowest := enumerationBase.rangeHighest+1;
END;
x.SetEnumerationBase(baseType);
ELSE lowest := 0;
END;
highest := lowest-1;
CheckEnumerationScope(x.enumerationScope, highest);
x.SetRange(lowest, highest);
x.SetState(SyntaxTree.Resolved);
END;
resolvedType := ResolvedType(x);
END VisitEnumerationType;
PROCEDURE VisitRangeType(x: SyntaxTree.RangeType);
BEGIN
IF TypeNeedsResolution(x) THEN
x.SetState(SyntaxTree.Resolved);
END;
resolvedType := ResolvedType(x)
END VisitRangeType;
PROCEDURE VisitQualifiedType(x: SyntaxTree.QualifiedType);
VAR type: SyntaxTree.Type; typeDeclaration: SyntaxTree.TypeDeclaration;
BEGIN
IF TypeNeedsResolution(x) THEN
type := ResolveNamedType(x.qualifiedIdentifier, typeDeclaration);
x.SetResolved(type.resolved);
x.SetState(SyntaxTree.Resolved);
x.SetTypeDeclaration (typeDeclaration);
ELSIF ~(SyntaxTree.Resolved IN x.state) THEN
x.SetResolved(SyntaxTree.invalidType);
END;
resolvedType := x;
END VisitQualifiedType;
PROCEDURE VisitArrayType(x: SyntaxTree.ArrayType);
VAR arrayBase: SyntaxTree.Type;
BEGIN
IF TypeNeedsResolution(x) THEN
x.SetArrayBase(ResolveType(x.arrayBase));
IF x.arrayBase.resolved.isRealtime THEN x.SetRealtime(TRUE) END;
arrayBase := x.arrayBase.resolved;
IF x.length # NIL THEN
x.SetLength(ConstantIntegerGeq0(x.length));
END;
IF arrayBase IS SyntaxTree.ArrayType THEN
IF (x.form = SyntaxTree.Static) & (arrayBase(SyntaxTree.ArrayType).form = SyntaxTree.Open) THEN
Error(x.position,Diagnostics.Invalid,"forbidden static array of dynamic array");
END;
ELSIF arrayBase IS SyntaxTree.MathArrayType THEN
Error(x.position,Diagnostics.Invalid,"forbidden array mixed form");
END;
x.SetHasPointers(arrayBase.hasPointers);
x.SetState(SyntaxTree.Resolved);
END;
resolvedType := ResolvedType(x);
END VisitArrayType;
PROCEDURE ImportModule(name: SyntaxTree.Identifier; position: LONGINT);
VAR module: SyntaxTree.Module; import: SyntaxTree.Import; moduleScope: SyntaxTree.ModuleScope;
BEGIN
module := currentScope.ownerModule;
IF module.name=name THEN
ELSE
moduleScope := module.moduleScope;
import := moduleScope.FindImport(name);
IF import = NIL THEN
import := SyntaxTree.NewImport(position,name,name,TRUE);
moduleScope.AddImport(import);
Register(import,moduleScope,FALSE);
IF import.context = SyntaxTree.invalidIdentifier THEN import.SetContext(SELF.module.context) END;
VisitImport(import);
ELSIF import.direct=FALSE THEN
import.SetScope(module.moduleScope);
import.SetDirect(TRUE);
END;
import.MarkUsed
END;
END ImportModule;
PROCEDURE ImportThis(position: LONGINT; moduleName: SyntaxTree.Identifier; VAR m: SyntaxTree.Module; force: BOOLEAN): BOOLEAN;
VAR import: SyntaxTree.Import;
s: ARRAY 256 OF CHAR;
name: SyntaxTree.IdentifierString;
selfName: SyntaxTree.String;
BEGIN
IF (moduleName = module.name) & (module.context = Global.A2Name) THEN
m := module
ELSE
import := module.moduleScope.ImportByModuleName(moduleName,SyntaxTree.NewIdentifier("A2"));
IF import = NIL THEN
import := SyntaxTree.NewImport(-1,moduleName,moduleName,TRUE);
import.SetContext(SyntaxTree.NewIdentifier("A2"));
IF ~AddImport(module,import) OR (import.module = NIL) THEN
IF force THEN
s := "Module ";
Basic.GetString(moduleName,name);
Strings.Append(s,name);
Strings.Append(s," cannot be imported.");
Error(position,Diagnostics.Invalid,s);
END;
RETURN FALSE
END;
ELSIF import.module = NIL THEN
RETURN FALSE
END;
m := import.module;
END;
RETURN TRUE
END ImportThis;
PROCEDURE GetRuntimeProcedure(position: LONGINT; moduleName: SyntaxTree.Identifier; CONST procedureName: ARRAY OF CHAR; VAR procedure: SyntaxTree.Procedure; force: BOOLEAN): BOOLEAN;
VAR runtimeModule: SyntaxTree.Module; name: Scanner.IdentifierString; s: ARRAY 256 OF CHAR;
BEGIN
IF ImportThis(position, moduleName,runtimeModule,force) THEN
procedure := runtimeModule.moduleScope.FindProcedure(SyntaxTree.NewIdentifier(procedureName));
IF procedure = NIL THEN
s := "Procedure ";
Basic.GetString(moduleName,name);
Strings.Append(s,name);
Strings.Append(s,".");
Strings.Append(s,procedureName);
Strings.Append(s," not present");
Error(position,Diagnostics.Invalid,s);
RETURN FALSE
ELSE
RETURN TRUE
END;
ELSE RETURN FALSE
END;
END GetRuntimeProcedure;
PROCEDURE VisitMathArrayType(x: SyntaxTree.MathArrayType);
VAR arrayBase: SyntaxTree.Type;
BEGIN
IF TypeNeedsResolution(x) THEN
x.SetArrayBase(ResolveType(x.arrayBase));
IF x.length # NIL THEN
x.SetLength(ConstantIntegerGeq0(x.length));
END;
arrayBase := x.arrayBase;
IF arrayBase # NIL THEN
arrayBase := arrayBase.resolved;
IF arrayBase = SyntaxTree.invalidType THEN
ELSIF arrayBase IS SyntaxTree.ArrayType THEN
Error(x.position,Diagnostics.Invalid,"forbidden array mixed form");
ELSIF arrayBase IS SyntaxTree.MathArrayType THEN
IF (x.form = SyntaxTree.Tensor) OR (arrayBase(SyntaxTree.MathArrayType).form = SyntaxTree.Tensor) THEN
Error(x.position,Diagnostics.Invalid,"forbidden Tensor Array mix")
ELSIF (x.form=SyntaxTree.Static) & (arrayBase(SyntaxTree.MathArrayType).form # SyntaxTree.Static) THEN
Error(x.position,Diagnostics.Invalid,"forbidden static array of dynamic array")
END;
END;
IF x.form = SyntaxTree.Static THEN
x.SetIncrement(system.SizeOf(arrayBase));
END;
x.SetHasPointers((x.form # SyntaxTree.Static) OR arrayBase.hasPointers);
END;
x.SetState(SyntaxTree.Resolved);
END;
resolvedType := ResolvedType(x);
END VisitMathArrayType;
PROCEDURE AnonymousTypeDeclaration(x: SyntaxTree.Type; CONST prefix: ARRAY OF CHAR);
VAR typeDeclaration: SyntaxTree.TypeDeclaration; name,number: Scanner.IdentifierString;
BEGIN
Strings.IntToStr(x.position,number);
COPY(prefix,name);
Strings.Append(name,"@");
Strings.Append(name,number);
typeDeclaration := SyntaxTree.NewTypeDeclaration(x.position,SyntaxTree.NewIdentifier(name));
typeDeclaration.SetDeclaredType(x);
typeDeclaration.SetAccess(SyntaxTree.Hidden);
x.SetTypeDeclaration(typeDeclaration);
currentScope.AddTypeDeclaration(typeDeclaration);
typeDeclaration.SetScope(currentScope);
END AnonymousTypeDeclaration;
PROCEDURE FixPointerType(type: SyntaxTree.PointerType);
VAR resolved: SyntaxTree.Type; position: LONGINT; recordType: SyntaxTree.RecordType;
BEGIN
ASSERT(type.pointerBase # NIL);
position := type.pointerBase.position;
IF (type.pointerBase IS SyntaxTree.RecordType) THEN
type.pointerBase(SyntaxTree.RecordType).SetPointerType(type);
END;
resolved := ResolveType(type.pointerBase);
IF (resolved.resolved IS SyntaxTree.RecordType) OR (resolved.resolved IS SyntaxTree.ArrayType) THEN
type.SetPointerBase(resolved);
IF (resolved.resolved IS SyntaxTree.RecordType) THEN
recordType := resolved.resolved(SyntaxTree.RecordType);
IF recordType.isObject & (recordType.baseType # NIL) THEN
IF type.isRealtime & ~recordType.baseType.resolved.isRealtime THEN
Error(position,Diagnostics.Invalid,"base type of object must be a realtime object");
ELSIF ~type.isRealtime & recordType.baseType.resolved.isRealtime THEN
Error(position,Diagnostics.Invalid,"extensions of realtime objects must be explicitly declared as realtime objects");
END;
END;
END;
IF type.isRealtime & ~resolved.resolved.isRealtime THEN
Error(position,Diagnostics.Invalid,"realtime object contains references to non-realtime objects");
END
ELSE
Error(position,Diagnostics.Invalid,"forbidden pointer base type");
type.SetPointerBase(SyntaxTree.invalidType)
END
END FixPointerType;
PROCEDURE VisitPointerType(x: SyntaxTree.PointerType);
VAR recordType: SyntaxTree.RecordType; recordBaseType: SyntaxTree.Type;
modifiers: SyntaxTree.Modifier; position: LONGINT;
BEGIN
IF TypeNeedsResolution(x) THEN
modifiers := x.modifiers;
x.SetRealtime(HasFlag(modifiers,Global.NameRealtime, position));
CheckModifiers(modifiers);
IF x.pointerBase IS SyntaxTree.RecordType THEN
recordType := x.pointerBase(SyntaxTree.RecordType);
recordBaseType := ResolveType(recordType.baseType);
recordType.SetBaseType(recordBaseType);
END;
typeFixes.Add(x,currentScope);
x.SetState(SyntaxTree.Resolved);
END;
resolvedType := ResolvedType(x)
END VisitPointerType;
PROCEDURE VisitPortType(x: SyntaxTree.PortType);
VAR channelType: SyntaxTree.Type; value: LONGINT;
BEGIN
IF TypeNeedsResolution(x) THEN
x.SetSizeExpression(ResolveExpression(x.sizeExpression));
IF (x.sizeExpression # NIL) & CheckPositiveIntegerValue(x.sizeExpression,value,FALSE) THEN
x.SetSize(value)
ELSE
x.SetSize(system.SizeOf(system.integerType));
END;
x.SetState(SyntaxTree.Resolved);
END;
resolvedType := ResolvedType(x)
END VisitPortType;
PROCEDURE FixProcedureType(procedureType: SyntaxTree.ProcedureType);
VAR resolved: SyntaxTree.Type; returnParameter,parameter : SyntaxTree.Parameter;
BEGIN
resolved := ResolveType(procedureType.returnType);
IF (resolved # NIL) & (resolved.resolved IS SyntaxTree.ArrayType) & (resolved.resolved(SyntaxTree.ArrayType).length = NIL) THEN
Error(procedureType.position,Diagnostics.Invalid,"forbidden open array return type");
END;
procedureType.SetReturnType(resolved);
IF (resolved # NIL) THEN
parameter := SyntaxTree.NewParameter(procedureType.position,procedureType,Global.ResultName, SyntaxTree.VarParameter);
parameter.SetType(procedureType.returnType);
parameter.SetAccess(SyntaxTree.Hidden);
VisitParameter(parameter);
procedureType.SetReturnParameter(parameter);
END;
parameter :=procedureType.firstParameter;
WHILE (parameter # NIL) DO
VisitParameter(parameter);
parameter := parameter.nextParameter;
END;
END FixProcedureType;
PROCEDURE HasFlag(VAR modifiers: SyntaxTree.Modifier; name: SyntaxTree.Identifier; VAR position: LONGINT): BOOLEAN;
VAR prev,this: SyntaxTree.Modifier;
BEGIN
this := modifiers;prev := NIL;
WHILE (this # NIL) & (this.identifier # name) DO
prev := this; this := this.nextModifier;
END;
IF this # NIL THEN
IF this.expression # NIL THEN
Error(this.position,Diagnostics.Invalid,"unexpected expression");
END;
this.Resolved;
RETURN TRUE
ELSE
RETURN FALSE
END;
END HasFlag;
PROCEDURE HasValue(modifiers: SyntaxTree.Modifier; name: SyntaxTree.Identifier; VAR position: LONGINT; VAR value: LONGINT): BOOLEAN;
VAR prev,this: SyntaxTree.Modifier;
BEGIN
this := modifiers;prev := NIL;
WHILE (this # NIL) & (this.identifier # name) DO
prev := this; this := this.nextModifier;
END;
IF this # NIL THEN
IF this.expression = NIL THEN
Error(this.position,Diagnostics.Invalid,"expected expression value");
ELSE
this.SetExpression(ConstantExpression(this.expression));
IF CheckIntegerValue(this.expression,value) THEN END;
END;
this.Resolved;
position := this.position;
RETURN TRUE
ELSE RETURN FALSE
END;
END HasValue;
PROCEDURE CheckModifiers(modifiers: SyntaxTree.Modifier);
VAR this: SyntaxTree.Modifier;
BEGIN
this := modifiers;
WHILE this # NIL DO
IF ~this.resolved THEN
Error(this.position,Diagnostics.Invalid,"unexpected modifier");
END;
this := this.nextModifier
END;
END CheckModifiers;
PROCEDURE VisitProcedureType(procedureType: SyntaxTree.ProcedureType);
VAR modifiers: SyntaxTree.Modifier; value,position: LONGINT;
BEGIN
IF TypeNeedsResolution(procedureType) THEN
modifiers := procedureType.modifiers;
IF HasFlag(modifiers, Global.NameWinAPI,position) THEN procedureType.SetCallingConvention(SyntaxTree.WinAPICallingConvention)
ELSIF HasFlag(modifiers, Global.NameInterrupt,position) THEN
procedureType.SetInterrupt(TRUE);
procedureType.SetCallingConvention(SyntaxTree.InterruptCallingConvention)
ELSIF HasFlag(modifiers,Global.NameC,position) THEN
IF useDarwinCCalls THEN
procedureType.SetCallingConvention(SyntaxTree.DarwinCCallingConvention)
ELSE
procedureType.SetCallingConvention(SyntaxTree.CCallingConvention)
END
END;
IF HasValue(modifiers,Global.NameStackAligned,position,value) THEN procedureType.SetStackAlignment(value) END;
IF HasFlag(modifiers, Global.NameDelegate,position) THEN procedureType.SetDelegate(TRUE) END;
IF HasFlag(modifiers, Global.NameRealtime,position) THEN procedureType.SetRealtime(TRUE) END;
CheckModifiers(modifiers);
typeFixes.Add(procedureType,currentScope);
procedureType.SetHasPointers(procedureType.isDelegate);
procedureType.SetState(SyntaxTree.Resolved);
END;
resolvedType := ResolvedType(procedureType)
END VisitProcedureType;
PROCEDURE VisitRecordType(x: SyntaxTree.RecordType);
VAR resolved, baseType: SyntaxTree.Type; position: LONGINT;
numberMethods: LONGINT; recordBase, recordType: SyntaxTree.RecordType; procedure: SyntaxTree.Procedure;
symbol: SyntaxTree.Symbol; isRealtime: BOOLEAN;
hasPointers: BOOLEAN;
PROCEDURE IsPointerToRecord(type: SyntaxTree.Type; VAR recordType: SyntaxTree.RecordType): BOOLEAN;
BEGIN
type := type.resolved;
IF (type IS SyntaxTree.PointerType) &
(type(SyntaxTree.PointerType).pointerBase.resolved # NIL) &
(type(SyntaxTree.PointerType).pointerBase.resolved IS SyntaxTree.RecordType) THEN
recordType := type(SyntaxTree.PointerType).pointerBase.resolved(SyntaxTree.RecordType);
RETURN TRUE
ELSE
RETURN FALSE
END;
END IsPointerToRecord;
BEGIN
IF TypeNeedsResolution(x) THEN
hasPointers := FALSE;
IF x.baseType # NIL THEN
position := x.baseType.position;
baseType := ResolveType(x.baseType);
resolved := baseType.resolved;
hasPointers := hasPointers OR resolved.hasPointers;
IF x.isObject THEN
ASSERT(x.pointerType # NIL);
IF resolved = SyntaxTree.invalidType THEN
ELSIF resolved IS SyntaxTree.ObjectType THEN
baseType := NIL
ELSIF IsPointerToRecord(resolved,recordType) THEN
ELSIF resolved IS SyntaxTree.MathArrayType THEN
ELSE
Error(position, Diagnostics.Invalid,"object does not extend pointer to record, object or math array ")
END;
ELSIF x.pointerType # NIL THEN
IF resolved = SyntaxTree.invalidType THEN
ELSIF IsPointerToRecord(resolved,recordType) THEN
IF recordType.isObject THEN Error(position, Diagnostics.Invalid,"pointer to record extends object") END;
ELSIF resolved IS SyntaxTree.RecordType THEN
ELSE
Error(position, Diagnostics.Invalid,"pointer to record does not extend pointer to record or record")
END;
ELSE
IF resolved IS SyntaxTree.RecordType THEN
ELSE
Error(position, Diagnostics.Invalid,"record does not extend record")
END;
END;
x.SetBaseType(baseType);
IF x.Level() > 15 THEN
Error(position,Diagnostics.Invalid,"record/object inheritance level too high");
END;
END;
Declarations(x.recordScope);
ResolveArrayStructure(x);
recordBase := x.GetBaseRecord();
IF recordBase = NIL THEN numberMethods := 0
ELSE numberMethods := recordBase.recordScope.numberMethods
END;
isRealtime := TRUE;
hasPointers := FALSE;
symbol := x.recordScope.firstSymbol;
WHILE symbol # NIL DO
IF symbol IS SyntaxTree.Variable THEN
isRealtime := isRealtime & symbol.type.resolved.isRealtime;
hasPointers := hasPointers OR symbol.type.resolved.hasPointers;
END;
IF symbol IS SyntaxTree.Procedure THEN
procedure := symbol(SyntaxTree.Procedure);
IF procedure.super # NIL THEN
procedure.SetMethodNumber(procedure.super.methodNumber)
ELSE
procedure.SetMethodNumber(numberMethods);
INC(numberMethods);
END;
END;
symbol := symbol.nextSymbol;
END;
IF isRealtime THEN x.SetRealtime(TRUE) END;
x.recordScope.SetNumberMethods(numberMethods);
IF (x.isObject) & (x.baseType # NIL) & (x.baseType.resolved IS SyntaxTree.RecordType) THEN
Error(x.position,Diagnostics.Invalid,"object extends a record")
END;
IF (x.typeDeclaration = NIL) THEN
IF (x.pointerType # NIL) & (x.pointerType.resolved.typeDeclaration # NIL) THEN
x.SetTypeDeclaration(x.pointerType.resolved.typeDeclaration);
ELSE
AnonymousTypeDeclaration(x,"Anonymous");
END;
END;
x.SetHasPointers(hasPointers);
x.SetState(SyntaxTree.Resolved);
END;
resolvedType := ResolvedType(x);
END VisitRecordType;
PROCEDURE VisitCellType(x: SyntaxTree.CellType);
VAR
symbol: SyntaxTree.Symbol; isRealtime: BOOLEAN; parameter: SyntaxTree.Parameter; type: SyntaxTree.Type; len: LONGINT;
modifier: SyntaxTree.Modifier; expression: SyntaxTree.Expression; position,value: LONGINT;
BEGIN
IF TypeNeedsResolution(x) THEN
modifier := x.modifiers;
IF ~x.isCellNet THEN
IF HasValue(modifier,Global.NameDataMemorySize,position,value) THEN END;
IF HasValue(modifier,Global.NameCodeMemorySize,position,value) THEN END;
IF HasFlag(modifier, Global.NameVector,position) THEN END;
IF HasFlag(modifier, Global.NameFloatingPoint, position) THEN END;
symbol := system.activeCellsCapabilities;
WHILE symbol # NIL DO
IF HasFlag(modifier, symbol.name, position) THEN END;
symbol := symbol.nextSymbol;
END;
ELSE
END;
CheckModifiers(modifier);
parameter :=x.firstParameter;
WHILE (parameter # NIL) DO
VisitParameter(parameter);
type := parameter.type.resolved;
IF ~(type IS SyntaxTree.PortType) THEN
IF ~IsStaticArray(type,type,len) OR ~(type IS SyntaxTree.PortType) THEN
Error(parameter.position, Diagnostics.Invalid, "invalid type, must be port or static array of port ");
END;
END;
parameter := parameter.nextParameter;
END;
Declarations(x.cellScope);
symbol := x.cellScope.firstSymbol;
WHILE symbol # NIL DO
IF symbol IS SyntaxTree.Variable THEN
isRealtime := isRealtime & symbol.type.resolved.isRealtime;
END;
symbol := symbol.nextSymbol;
END;
IF isRealtime THEN x.SetRealtime(TRUE) END;
IF (x.typeDeclaration = NIL) THEN
AnonymousTypeDeclaration(x,"Anonymous");
END;
x.SetState(SyntaxTree.Resolved);
IF x.cellScope.bodyProcedure = NIL THEN
Error(x.position, Diagnostics.Invalid, "Forbidden empty Body.");
END;
END;
resolvedType := ResolvedType(x);
END VisitCellType;
PROCEDURE ResolveArrayStructure*(recordType: SyntaxTree.RecordType);
VAR
indexOperatorCount, i: LONGINT;
arrayAccessOperators: SyntaxTree.ArrayAccessOperators;
isTensor: BOOLEAN;
BEGIN
IF recordType.isObject & (recordType.baseType # NIL) THEN
recordType.SetArrayStructure(MathArrayStructureOfType(recordType.baseType.resolved))
END;
IF recordType.HasArrayStructure() THEN
isTensor := recordType.arrayStructure.form = SyntaxTree.Tensor;
arrayAccessOperators.len := NIL;
arrayAccessOperators.generalRead := NIL;
arrayAccessOperators.generalWrite := NIL;
IF isTensor THEN
indexOperatorCount := TwoToThePowerOf(MaxTensorIndexOperatorSize + 1) - 2
ELSE
indexOperatorCount := TwoToThePowerOf(recordType.arrayStructure.Dimensionality())
END;
NEW(arrayAccessOperators.read, indexOperatorCount);
NEW(arrayAccessOperators.write, indexOperatorCount);
FOR i := 0 TO indexOperatorCount - 1 DO
arrayAccessOperators.read[i] := NIL;
arrayAccessOperators.write[i] := NIL
END;
CollectArrayAccessOperators(recordType.recordScope, recordType.arrayStructure, arrayAccessOperators);
IF arrayAccessOperators.len = NIL THEN
Error(recordType.position, Diagnostics.Invalid, "LEN operator missing")
END;
IF isTensor THEN
IF arrayAccessOperators.generalRead = NIL THEN Error(recordType.position, Diagnostics.Invalid, "general read operator missing") END;
IF arrayAccessOperators.generalWrite = NIL THEN Error(recordType.position, Diagnostics.Invalid, "general write operator missing") END;
ELSE
IF arrayAccessOperators.generalRead # NIL THEN Error(recordType.position, Diagnostics.Invalid, "general read operator not applicable") END;
IF arrayAccessOperators.generalWrite # NIL THEN Error(recordType.position, Diagnostics.Invalid, "general write operator not applicable") END;
IF arrayAccessOperators.read[indexOperatorCount - 1] = NIL THEN Error(recordType.position, Diagnostics.Invalid, "read operator on ranges missing") END;
IF arrayAccessOperators.write[indexOperatorCount - 1] = NIL THEN Error(recordType.position, Diagnostics.Invalid, "write operator on ranges missing") END;
END;
recordType.SetArrayAccessOperators(arrayAccessOperators)
ELSE
IF recordType.recordScope.firstOperator # NIL THEN
RETURN;
Error(recordType.recordScope.firstOperator.position, Diagnostics.Invalid, "operator declared for record type without array structure")
END
END
END ResolveArrayStructure;
PROCEDURE CollectArrayAccessOperators(recordScope: SyntaxTree.RecordScope; arrayStructure: SyntaxTree.MathArrayType; VAR arrayAccessOperators: SyntaxTree.ArrayAccessOperators);
VAR
baseType: SyntaxTree.Type;
operator: SyntaxTree.Operator;
isReadOperator, isGeneralOperator: BOOLEAN;
indexListSize, indexListKind, hashValue: LONGINT;
BEGIN
baseType := recordScope.ownerRecord.baseType;
IF (baseType # NIL) & (baseType.resolved IS SyntaxTree.PointerType) THEN
baseType := baseType.resolved(SyntaxTree.PointerType).pointerBase.resolved
END;
IF (baseType # NIL) & (baseType.resolved IS SyntaxTree.RecordType) THEN
CollectArrayAccessOperators(baseType(SyntaxTree.RecordType).recordScope, arrayStructure, arrayAccessOperators);
END;
operator := recordScope.firstOperator;
WHILE operator # NIL DO
IF operator.name=SyntaxTree.NewIdentifier("LEN") THEN
IF CheckLenOperator(operator, arrayStructure) THEN arrayAccessOperators.len := operator END
ELSIF operator.name = SyntaxTree.NewIdentifier("[]") THEN
IF CheckIndexOperator(operator, arrayStructure, isReadOperator, isGeneralOperator, indexListSize, indexListKind) THEN
IF isGeneralOperator THEN
IF isReadOperator THEN
arrayAccessOperators.generalRead := operator
ELSE
arrayAccessOperators.generalWrite := operator
END
ELSE
hashValue := IndexOperatorHash(indexListSize, indexListKind, arrayStructure.form = SyntaxTree.Tensor);
IF isReadOperator THEN
arrayAccessOperators.read[hashValue] := operator
ELSE
arrayAccessOperators.write[hashValue] := operator
END
END
END
ELSE
Error(operator.position, Diagnostics.Invalid, 'invalid operator')
END;
operator := operator.nextOperator
END
END CollectArrayAccessOperators;
PROCEDURE IndexOperatorHash(indexListSize, indexListKind: LONGINT; isTensor: BOOLEAN): LONGINT;
VAR result: LONGINT;
BEGIN
IF isTensor THEN
IF indexListSize > MaxTensorIndexOperatorSize THEN
result := -1
ELSE
result := TwoToThePowerOf(indexListSize) - 2 + indexListKind
END
ELSE
result := indexListKind
END;
RETURN result
END IndexOperatorHash;
PROCEDURE TwoToThePowerOf(exponent: LONGINT): LONGINT;
VAR result, i: LONGINT;
BEGIN
result := 1;
FOR i := 1 TO exponent DO
result := result * 2;
END;
RETURN result
END TwoToThePowerOf;
PROCEDURE CheckLenOperator(operator: SyntaxTree.Operator; arrayStructure: SyntaxTree.MathArrayType): BOOLEAN;
VAR
procedureType: SyntaxTree.ProcedureType;
returnedArrayType: SyntaxTree.MathArrayType;
result: BOOLEAN;
BEGIN
result := FALSE;
procedureType := operator.type.resolved(SyntaxTree.ProcedureType);
IF (procedureType.numberParameters = 0) THEN
IF (procedureType.returnType # NIL) & (procedureType.returnType.resolved IS SyntaxTree.MathArrayType) THEN
returnedArrayType := procedureType.returnType.resolved(SyntaxTree.MathArrayType);
IF system.longintType.SameType(returnedArrayType.arrayBase.resolved) THEN
IF returnedArrayType.form = SyntaxTree.Open THEN
result := TRUE
ELSIF arrayStructure.form # SyntaxTree.Tensor THEN
IF (returnedArrayType.form = SyntaxTree.Static) & (returnedArrayType.staticLength = arrayStructure.Dimensionality()) THEN
result := TRUE
END
END
END
END
END;
IF result THEN
operator.SetAccess(SyntaxTree.Public + SyntaxTree.Protected + SyntaxTree.Internal)
ELSE
Error(operator.position, Diagnostics.Invalid, "LEN operator with invalid signature");
END;
RETURN result
END CheckLenOperator;
PROCEDURE CheckIndexOperator(operator: SyntaxTree.Operator; arrayStructure: SyntaxTree.MathArrayType; VAR isReadOperator, isGeneralOperator: BOOLEAN; VAR indexListSize, indexListKind: LONGINT): BOOLEAN;
VAR
elementType, otherElementType, dataType: SyntaxTree.Type;
procedureType: SyntaxTree.ProcedureType;
mathArrayType: SyntaxTree.MathArrayType;
parameter: SyntaxTree.Parameter;
parameterCount, rangeCount, i: LONGINT;
hasTypeError: BOOLEAN;
BEGIN
procedureType := operator.type.resolved(SyntaxTree.ProcedureType);
parameterCount := procedureType.numberParameters;
isReadOperator := (procedureType.returnType # NIL);
IF isReadOperator THEN
indexListSize := parameterCount;
ELSE
indexListSize := parameterCount - 1;
END;
IF indexListSize < 1 THEN
Error(operator.position, Diagnostics.Invalid, "index operator with too few parameters");
RETURN FALSE
END;
IF procedureType.firstParameter.type.resolved IS SyntaxTree.MathArrayType THEN
isGeneralOperator := TRUE;
IF indexListSize > 1 THEN
Error(operator.position, Diagnostics.Invalid, "index operator with too many parameters");
RETURN FALSE
END;
mathArrayType := procedureType.firstParameter.type.resolved(SyntaxTree.MathArrayType);
IF ~((mathArrayType.arrayBase.resolved IS SyntaxTree.RangeType) & (mathArrayType.form = SyntaxTree.Open)) THEN
Error(operator.position, Diagnostics.Invalid, "index parameter not dynamic math array of range");
RETURN FALSE
END;
parameter := procedureType.firstParameter.nextParameter
ELSE
isGeneralOperator := FALSE;
IF arrayStructure.form = SyntaxTree.Tensor THEN
IF indexListSize > MaxTensorIndexOperatorSize THEN
Error(operator.position, Diagnostics.Invalid, "too many index parameters for tensor");
RETURN FALSE
END
ELSE
IF indexListSize # arrayStructure.Dimensionality() THEN
Error(operator.position, Diagnostics.Invalid, "index parameter count does not match dimensionality");
RETURN FALSE
END
END;
indexListKind := 0;
rangeCount := 0;
parameter := procedureType.firstParameter;
FOR i := 1 TO indexListSize DO
indexListKind := indexListKind * 2;
IF parameter.type.resolved IS SyntaxTree.IntegerType THEN
ELSIF parameter.type.resolved IS SyntaxTree.RangeType THEN
INC(indexListKind);
INC(rangeCount)
ELSE
Error(parameter.position, Diagnostics.Invalid, "integer or range expected");
RETURN FALSE
END;
parameter := parameter.nextParameter
END;
END;
IF isReadOperator THEN
dataType := procedureType.returnType
ELSE
dataType := parameter.type
END;
elementType := arrayStructure.ElementType();
hasTypeError := FALSE;
IF isGeneralOperator THEN
IF dataType.resolved IS SyntaxTree.MathArrayType THEN
mathArrayType := dataType.resolved(SyntaxTree.MathArrayType);
IF ~((mathArrayType.arrayBase.resolved = elementType.resolved) & (mathArrayType.form = SyntaxTree.Tensor)) THEN
hasTypeError := TRUE
END
ELSE
hasTypeError := TRUE
END
ELSE
IF rangeCount = 0 THEN
IF dataType.resolved # elementType.resolved THEN hasTypeError := TRUE END
ELSE
IF dataType.resolved IS SyntaxTree.MathArrayType THEN
mathArrayType := dataType.resolved(SyntaxTree.MathArrayType);
IF mathArrayType.IsFullyDynamic() THEN
IF mathArrayType.Dimensionality() = rangeCount THEN
otherElementType := mathArrayType.ElementType();
IF otherElementType.resolved # elementType.resolved THEN hasTypeError := TRUE END
ELSE
hasTypeError := TRUE
END
ELSE
hasTypeError := TRUE
END
ELSE
hasTypeError := TRUE
END
END
END;
IF hasTypeError THEN
IF isReadOperator THEN
Error(operator.position, Diagnostics.Invalid, "return type does not match")
ELSE
Error(parameter.position, Diagnostics.Invalid, "type of last parameter does not match")
END;
RETURN FALSE
END;
operator.SetAccess(SyntaxTree.Public + SyntaxTree.Protected + SyntaxTree.Internal);
RETURN TRUE
END CheckIndexOperator;
PROCEDURE FixTypes;
VAR p: ANY; prevScope: SyntaxTree.Scope;
BEGIN
prevScope := currentScope;
p := typeFixes.Get(currentScope);
WHILE p # NIL DO
ASSERT(currentScope # NIL);
ASSERT(p IS SyntaxTree.Type);
IF p IS SyntaxTree.PointerType THEN
FixPointerType(p(SyntaxTree.PointerType))
ELSIF p IS SyntaxTree.ProcedureType THEN
FixProcedureType(p(SyntaxTree.ProcedureType))
ELSE
HALT(100);
END;
p := typeFixes.Get(currentScope);
END;
currentScope :=prevScope;
END FixTypes;
PROCEDURE ResolveType(x: SyntaxTree.Type): SyntaxTree.Type;
VAR prev,resolved: SyntaxTree.Type;
BEGIN
prev := resolvedType;
resolvedType := SyntaxTree.invalidType;
IF x = NIL THEN resolvedType := NIL
ELSE x.Accept(SELF); ASSERT(resolvedType # NIL);
END;
resolved := resolvedType;
resolvedType := prev;
ASSERT((resolved = NIL) OR (resolved.resolved # NIL));
RETURN resolved
END ResolveType;
PROCEDURE RegularType(position: LONGINT; type: SyntaxTree.Type): SyntaxTree.Type;
VAR result: SyntaxTree.Type;
BEGIN
result := SyntaxTree.invalidType;
IF type = NIL THEN Error(position,Diagnostics.Invalid,"expression of type NIL");
ELSIF type = SyntaxTree.invalidType THEN
ELSIF type.resolved = SyntaxTree.importType THEN Error(position,Diagnostics.Invalid,"expression is an import");
ELSIF type.resolved = SyntaxTree.typeDeclarationType THEN Error(position,Diagnostics.Invalid,"expression is a type");
ELSE result := type.resolved
END;
RETURN result
END RegularType;
PROCEDURE SignatureCompatible(position: LONGINT; this, to: SyntaxTree.ProcedureType): BOOLEAN;
VAR result: BOOLEAN;
BEGIN
result := SameType(to,this);
IF ~result THEN
Error(position,Diagnostics.Invalid,"signature incompatible");
IF VerboseErrorMessage THEN
Printout.Info("this",this);
Printout.Info("to",to);
END;
ELSIF (to(SyntaxTree.ProcedureType).isRealtime) & ~(this(SyntaxTree.ProcedureType).isRealtime) THEN
Error(position,Diagnostics.Invalid,"signature incompatible: realtime flag must be inherited");
END;
RETURN result
END SignatureCompatible;
PROCEDURE ParameterCompatible(formal: SyntaxTree.Parameter; actual: SyntaxTree.Expression): BOOLEAN;
VAR formalType, actualType: SyntaxTree.Type; result,error: BOOLEAN;
BEGIN
formalType := RegularType(formal.position,formal.type);
actualType := RegularType(actual.position,actual.type);
error := FALSE;
IF actualType = SyntaxTree.invalidType THEN
ELSIF (formal.kind = SyntaxTree.VarParameter) THEN
IF (formal.ownerType(SyntaxTree.ProcedureType).callingConvention = SyntaxTree.WinAPICallingConvention) & (actualType IS SyntaxTree.NilType) THEN
result := TRUE;
ELSIF ~IsVariable(actual) THEN
result := FALSE; error := TRUE;
IF actual IS SyntaxTree.ProcedureCallDesignator THEN
Error(actual.position,Diagnostics.Invalid,"not a variable: no operator for writing");
ELSE
Error(actual.position,Diagnostics.Invalid,"is not a variable");
END;
IF VerboseErrorMessage THEN
Printout.Info("actual",actual);
Printout.Info("formal",formal);
END;
ELSIF (formalType IS SyntaxTree.ByteType) OR (formalType IS SyntaxTree.RecordType) & (~formalType(SyntaxTree.RecordType).isObject) THEN
result := CompatibleTo(system,actualType,formalType);
ELSIF (formalType IS SyntaxTree.ArrayType) & (formalType(SyntaxTree.ArrayType).form = SyntaxTree.Open) THEN
result := OpenArrayCompatible(formalType(SyntaxTree.ArrayType),actualType);
ELSIF (formalType IS SyntaxTree.MathArrayType) THEN
IF IsArrayStructuredObjectType(actualType) THEN
actualType := MathArrayStructureOfType(actualType)
END;
result := MathArrayCompatible(formalType(SyntaxTree.MathArrayType),actualType);
IF result & (formalType(SyntaxTree.MathArrayType).form = SyntaxTree.Static) & (actualType(SyntaxTree.MathArrayType).form # SyntaxTree.Static) THEN
Error(actual.position,Diagnostics.Invalid,"incompatible non-static actual type");
END;
IF result & (actualType(SyntaxTree.MathArrayType).form = SyntaxTree.Tensor) & (formalType(SyntaxTree.MathArrayType).form # SyntaxTree.Tensor) THEN
Error(actual.position,Diagnostics.Invalid,"incompatible tensor (use a range expression)");
END;
ELSE
result := SameType(actualType,formalType)
END
ELSE
IF (formalType IS SyntaxTree.CharacterType) & (actualType IS SyntaxTree.StringType) & (actualType(SyntaxTree.StringType).length = 2) THEN
actualType := system.characterType;
END;
IF (formal.ownerType(SyntaxTree.ProcedureType).callingConvention = SyntaxTree.WinAPICallingConvention) & ((actualType IS SyntaxTree.NilType) OR (actualType IS SyntaxTree.AnyType)) THEN
result := TRUE;
ELSIF (formalType IS SyntaxTree.ArrayType) & (formalType(SyntaxTree.ArrayType).form = SyntaxTree.Open) THEN
result := OpenArrayCompatible(formalType(SyntaxTree.ArrayType),actualType);
ELSE
result := CompatibleTo(system,actualType,formalType);
IF result & (formalType IS SyntaxTree.MathArrayType) & (formalType(SyntaxTree.MathArrayType).form = SyntaxTree.Static) & (actualType(SyntaxTree.MathArrayType).form # SyntaxTree.Static) THEN
Error(actual.position,Diagnostics.Invalid,"incompatible non-static actual type");
END;
END;
END;
IF ~result & ~error THEN
Error(actual.position,Diagnostics.Invalid,"incompatible parameter");
IF VerboseErrorMessage THEN
Printout.Info("actual",actual);
Printout.Info("formal",formal);
END;
END;
RETURN result
END ParameterCompatible;
PROCEDURE AssignmentCompatible(VAR left: SyntaxTree.Designator; right: SyntaxTree.Expression): BOOLEAN;
VAR leftType,rightType: SyntaxTree.Type; VAR result: BOOLEAN;
BEGIN
result := FALSE;
leftType := RegularType(left.position,left.type);
rightType := RegularType(right.position,right.type);
IF (leftType IS SyntaxTree.CharacterType) & (rightType IS SyntaxTree.StringType) & (rightType(SyntaxTree.StringType).length = 2) THEN
rightType := system.characterType;
END;
IF IsArrayStructuredObjectType(leftType) THEN leftType := MathArrayStructureOfType(leftType) END;
IF (leftType = SyntaxTree.invalidType) OR (rightType = SyntaxTree.invalidType) THEN
result := TRUE;
ELSIF ~IsVariable(left) THEN
Error(left.position,Diagnostics.Invalid,"is not a variable");
IF VerboseErrorMessage THEN
Printout.Info("left",left);
Printout.Info("right",right);
END;
ELSIF ~CompatibleTo(system,rightType,leftType) THEN
Error(left.position,Diagnostics.Invalid,"incompatible assignment");
IF VerboseErrorMessage THEN
Printout.Info("left",left);
Printout.Info("right",right);
END;
ELSIF (right IS SyntaxTree.SymbolDesignator) & (right(SyntaxTree.SymbolDesignator).symbol IS SyntaxTree.Procedure) &
(right(SyntaxTree.SymbolDesignator).symbol(SyntaxTree.Procedure).scope IS SyntaxTree.ProcedureScope) THEN
Error(right.position,Diagnostics.Invalid,"forbidden assignment of a nested procedure");
ELSE
result := TRUE
END;
RETURN result
END AssignmentCompatible;
PROCEDURE VisitIntegerValue(value: SyntaxTree.IntegerValue);
VAR hugeint: HUGEINT;
BEGIN
hugeint := value(SyntaxTree.IntegerValue).hvalue;
value.SetType(Global.GetIntegerType(system,hugeint));
resolvedExpression := value
END VisitIntegerValue;
PROCEDURE VisitRealValue(value: SyntaxTree.RealValue);
VAR subtype: LONGINT; type: SyntaxTree.Type;
BEGIN
subtype := value(SyntaxTree.RealValue).subtype;
IF subtype = Scanner.Real THEN
type := system.realType
ELSIF subtype = Scanner.Longreal THEN
type := system.longrealType
ELSE
HALT(100)
END;
value.SetType(type);
resolvedExpression := value
END VisitRealValue;
PROCEDURE VisitComplexValue(value: SyntaxTree.ComplexValue);
VAR subtype: LONGINT; type: SyntaxTree.Type;
BEGIN
subtype := value(SyntaxTree.ComplexValue).subtype;
IF subtype = Scanner.Real THEN
type := system.complexType
ELSIF subtype = Scanner.Longreal THEN
type := system.longcomplexType
ELSE
HALT(100)
END;
value.SetType(type);
resolvedExpression := value
END VisitComplexValue;
PROCEDURE VisitSetValue(value: SyntaxTree.SetValue);
BEGIN
value.SetType(system.setType);
resolvedExpression := value
END VisitSetValue;
PROCEDURE VisitMathArrayValue(value: SyntaxTree.MathArrayValue);
BEGIN
value.SetType(SyntaxTree.invalidType);
resolvedExpression := value
END VisitMathArrayValue;
PROCEDURE VisitBooleanValue(value: SyntaxTree.BooleanValue);
BEGIN
value.SetType(system.booleanType);
resolvedExpression := value
END VisitBooleanValue;
PROCEDURE VisitStringValue(value: SyntaxTree.StringValue);
BEGIN
value.SetType(ResolveType(SyntaxTree.NewStringType(value.position,system.characterType,value.length)));
resolvedExpression := value
END VisitStringValue;
PROCEDURE VisitCharacterValue(value: SyntaxTree.CharacterValue);
BEGIN
value.SetType(system.characterType);
resolvedExpression := value
END VisitCharacterValue;
PROCEDURE VisitNilValue(value: SyntaxTree.NilValue);
BEGIN
value.SetType(system.nilType);
resolvedExpression := value
END VisitNilValue;
PROCEDURE VisitEnumerationValue(value: SyntaxTree.EnumerationValue);
BEGIN
value.SetType(currentScope(SyntaxTree.EnumerationScope).ownerEnumeration);
ASSERT(value.type # NIL);
resolvedExpression := value
END VisitEnumerationValue;
PROCEDURE VisitSet(set: SyntaxTree.Set);
VAR
i: LONGINT;
element: SyntaxTree.Expression;
constant: BOOLEAN;
elements: SyntaxTree.ExpressionList;
s: SET;
result: SyntaxTree.Expression;
value: SyntaxTree.Value;
PROCEDURE CheckElement(element: SyntaxTree.Expression): SyntaxTree.Expression;
VAR
left, right: SyntaxTree.Expression;
elementResult: SyntaxTree.Expression;
leftInteger, rightInteger: LONGINT;
BEGIN
IF element IS SyntaxTree.RangeExpression THEN
element(SyntaxTree.RangeExpression).SetContext(SyntaxTree.SetElement)
END;
elementResult := ResolveExpression(element);
IF elementResult = SyntaxTree.invalidExpression THEN
constant := FALSE
ELSIF elementResult IS SyntaxTree.RangeExpression THEN
left := elementResult(SyntaxTree.RangeExpression).first;
right := elementResult(SyntaxTree.RangeExpression).last;
ASSERT((left # NIL) & (right # NIL));
ASSERT(system.longintType.SameType(left.type.resolved) & system.longintType.SameType(right.type.resolved));
ELSE
IF elementResult.type.resolved IS SyntaxTree.IntegerType THEN
elementResult := NewConversion(elementResult.position, elementResult, system.longintType, NIL)
ELSE
Error(elementResult.position, Diagnostics.Invalid, "non integer element in set");
elementResult := SyntaxTree.invalidExpression;
constant := FALSE
END;
left := elementResult;
right := elementResult
END;
IF elementResult # SyntaxTree.invalidExpression THEN
IF IsIntegerValue(left,leftInteger) & IsIntegerValue(right,rightInteger) THEN
IF (leftInteger<0) OR (leftInteger >= system.setType.sizeInBits) THEN
Error(left.position,Diagnostics.Invalid,"not allowed set integer value");
IF (rightInteger<0) OR (rightInteger >= system.setType.sizeInBits) THEN
Error(right.position,Diagnostics.Invalid,"not allowed set integer value");
END
ELSIF (rightInteger<0) OR (rightInteger >= system.setType.sizeInBits) THEN
Error(right.position,Diagnostics.Invalid,"not allowed set integer value");
ELSE
IF rightInteger > MAX(SET) THEN rightInteger := MAX(SET) END;
s := s + {leftInteger..rightInteger};
END;
ELSE
constant := FALSE;
END
END;
RETURN elementResult
END CheckElement;
BEGIN
result := set; constant := TRUE; s := {}; elements := set.elements;
IF elements # NIL THEN
FOR i := 0 TO elements.Length()-1 DO
element := elements.GetExpression(i);
element := CheckElement(element);
IF element = SyntaxTree.invalidExpression THEN
result := SyntaxTree.invalidExpression
END;
elements.SetExpression(i,element);
END;
END;
IF constant THEN
value := SyntaxTree.NewSetValue(set.position,s);
value.SetType(system.setType);
result.SetResolved(value);
END;
result.SetType(system.setType);
resolvedExpression := result;
END VisitSet;
PROCEDURE VisitMathArrayExpression(x: SyntaxTree.MathArrayExpression);
VAR type: SyntaxTree.Type; isValue: BOOLEAN;
value: SyntaxTree.MathArrayValue; arrayType: SyntaxTree.Type;
PROCEDURE RecursivelyFindType(x: SyntaxTree.MathArrayExpression);
VAR position,numberElements,i: LONGINT; expression: SyntaxTree.Expression;
BEGIN
numberElements := x.elements.Length();
FOR i := 0 TO numberElements-1 DO
expression := x.elements.GetExpression(i);
IF expression IS SyntaxTree.MathArrayExpression THEN
RecursivelyFindType(expression(SyntaxTree.MathArrayExpression))
ELSE
position := expression.position;
expression := ResolveExpression(x.elements.GetExpression(i));
x.elements.SetExpression(i,expression);
IF type = NIL THEN
type := expression.type;
ELSIF CompatibleTo(system,expression.type,type) THEN
ELSIF CompatibleTo(system,type,expression.type) THEN
type := expression.type
ELSE
Error(expression.position,Diagnostics.Invalid, "incompatible element types");
type := SyntaxTree.invalidType;
END;
END;
END;
END RecursivelyFindType;
PROCEDURE RecursivelySetExpression(x: SyntaxTree.MathArrayExpression);
VAR position,numberElements,i: LONGINT; expression: SyntaxTree.Expression;
BEGIN
numberElements := x.elements.Length();
FOR i := 0 TO numberElements-1 DO
expression := x.elements.GetExpression(i);
IF expression IS SyntaxTree.MathArrayExpression THEN
RecursivelySetExpression(expression(SyntaxTree.MathArrayExpression));
ELSE
position := expression.position;
expression := NewConversion(position,x.elements.GetExpression(i),type,NIL);
x.elements.SetExpression(i,expression);
isValue := isValue & (expression.resolved # NIL);
END;
END;
END RecursivelySetExpression;
PROCEDURE RecursivelySetType(x: SyntaxTree.MathArrayExpression): SyntaxTree.Type;
VAR numberElements,i,size,gsize: LONGINT; baseType: SyntaxTree.Type;expression: SyntaxTree.Expression;
arrayType: SyntaxTree.MathArrayType;
BEGIN
numberElements := x.elements.Length();
baseType := NIL;
gsize := 0;
FOR i := 0 TO numberElements-1 DO
expression := x.elements.GetExpression(i);
IF expression IS SyntaxTree.MathArrayExpression THEN
size := expression(SyntaxTree.MathArrayExpression).elements.Length();
IF i=0 THEN
gsize := size;
baseType := RecursivelySetType(expression(SyntaxTree.MathArrayExpression));
ELSIF (baseType = type) OR (gsize # size) THEN Error(expression.position,Diagnostics.Invalid, "invalid array dimensions");
ELSE expression.SetType(baseType)
END;
ELSIF baseType = NIL THEN baseType := type;
ELSIF baseType # type THEN Error(expression.position,Diagnostics.Invalid, "invalid array dimensions");
END;
END;
arrayType := SyntaxTree.NewMathArrayType(x.position,NIL, SyntaxTree.Static);
arrayType.SetArrayBase(baseType);
arrayType.SetLength(Global.NewIntegerValue(system,x.position,numberElements));
RETURN ResolveType(arrayType);
END RecursivelySetType;
BEGIN
type := NIL;
RecursivelyFindType(x);
isValue := TRUE;
RecursivelySetExpression(x);
arrayType := RecursivelySetType(x);
x.SetType(arrayType);
IF isValue THEN
value := SyntaxTree.NewMathArrayValue(x.position);
value.SetArray(x);
x.SetResolved(value);
value.SetType(arrayType);
END;
x.SetType(arrayType);
resolvedExpression := x;
END VisitMathArrayExpression;
PROCEDURE VisitUnaryExpression(unaryExpression: SyntaxTree.UnaryExpression);
VAR
left: SyntaxTree.Expression;
int: HUGEINT; real, imaginary: LONGREAL; set: SET; operator: LONGINT;
bool: BOOLEAN;
result: SyntaxTree.Expression; type: SyntaxTree.Type; operatorCall: SyntaxTree.Expression;
value: SyntaxTree.Value;
BEGIN
type := SyntaxTree.invalidType;
left := ResolveExpression(unaryExpression.left);
unaryExpression.SetLeft(left);
operator := unaryExpression.operator;
result := unaryExpression;
IF ~system.operatorDefined[operator] THEN
Error(left.position,Diagnostics.Invalid,"Operator Not Defined");
RETURN
ELSIF left.type = NIL THEN
Error(left.position,Diagnostics.Invalid,"Invalid Nil Argument in Unary Expression");
resolvedExpression := SyntaxTree.invalidExpression;
RETURN
ELSIF left = SyntaxTree.invalidExpression THEN
RETURN
END;
IF ~(left.type.resolved IS SyntaxTree.BasicType) OR (left.type.resolved IS SyntaxTree.ComplexType) THEN
operatorCall := NewOperatorCall(unaryExpression.position, operator,left,NIL,NIL);
END;
IF operatorCall # NIL THEN
result := operatorCall;
type := operatorCall.type;
ELSE
CASE unaryExpression.operator OF
|Scanner.Minus:
IF IsIntegerType(left.type.resolved) THEN
IF left.resolved # NIL THEN
int := -left.resolved(SyntaxTree.IntegerValue).hvalue;
value := SyntaxTree.NewIntegerValue(unaryExpression.position,int);
result.SetResolved(value);
type := Global.GetIntegerType(system,int);
value.SetType(type);
ELSE
type := left.type
END
ELSIF left.type.resolved IS SyntaxTree.FloatType THEN
IF IsRealValue(left,real) THEN
value := SyntaxTree.NewRealValue(unaryExpression.position,-real);
result.SetResolved(value);
type := left.type;
value.SetType(type);
ELSE
type := left.type;
END;
ELSIF left.type.resolved IS SyntaxTree.SetType THEN
IF IsSetValue(left,set) THEN
value := SyntaxTree.NewSetValue(unaryExpression.position,-set);
result.SetResolved(value);
type := left.type;
value.SetType(type);
ELSE
type := left.type;
END;
ELSIF left.type.resolved IS SyntaxTree.ComplexType THEN
IF IsComplexValue(left, real, imaginary) THEN
value := SyntaxTree.NewComplexValue(unaryExpression.position,-real, -imaginary);
result.SetResolved(value);
type := left.type;
value.SetType(type);
value(SyntaxTree.ComplexValue).SetSubtype(left.resolved(SyntaxTree.ComplexValue).subtype)
ELSE
type := left.type;
END
ELSE
Error(left.position,Diagnostics.Invalid,"unary operator not applicable");
END;
|Scanner.Not:
IF left.type.resolved IS SyntaxTree.BooleanType THEN
IF IsBooleanValue(left,bool) THEN
value := SyntaxTree.NewBooleanValue(unaryExpression.position,~bool);
result.SetResolved(value);
type := system.booleanType;
value.SetType(type);
ELSE
type := system.booleanType;
END;
ELSE
Error(left.position,Diagnostics.Invalid,"unary operator not applicable");
END;
|Scanner.Plus:
IF (left.type.resolved IS SyntaxTree.NumberType) THEN
result := left; type := left.type;
ELSE
Error(left.position,Diagnostics.Invalid,"unary operator not applicable");
END;
ELSE
Error(left.position,Diagnostics.Invalid,"unary operator not defined");
END;
END;
result.SetType(type);
resolvedExpression := result
END VisitUnaryExpression;
PROCEDURE MathArrayConversion(position: LONGINT; expression: SyntaxTree.Expression; type: SyntaxTree.Type): SyntaxTree.Expression;
VAR
result: SyntaxTree.Expression;
PROCEDURE BaseType(type: SyntaxTree.Type): SyntaxTree.Type;
BEGIN
type := type.resolved;
WHILE (type # NIL) & (type IS SyntaxTree.MathArrayType) DO
type := Resolved(type(SyntaxTree.MathArrayType).arrayBase);
END;
WHILE (type # NIL) & (type IS SyntaxTree.ArrayType) DO
type := Resolved(type(SyntaxTree.ArrayType).arrayBase);
END;
RETURN type
END BaseType;
BEGIN
result := SyntaxTree.invalidExpression;
IF (BaseType(type)=NIL) OR (BaseType(expression.type.resolved) = BaseType(type)) THEN
result := expression
ELSE
result := NewOperatorCall(position,Global.Conversion,expression,NIL,type);
IF result = NIL THEN
result := SyntaxTree.invalidExpression;
Error(position,Diagnostics.Invalid,"incompatible conversion");
IF VerboseErrorMessage THEN
Printout.Info("expression",expression);
Printout.Info("type",type);
END;
END;
END;
RETURN result
END MathArrayConversion;
PROCEDURE ConvertValue(position: LONGINT; expression: SyntaxTree.Value; type: SyntaxTree.Type): SyntaxTree.Expression;
VAR result: SyntaxTree.Expression; int: HUGEINT; real, imaginary: LONGREAL; set: SET; char: CHAR; string: Scanner.StringType;
BEGIN
result := expression; type := type.resolved;
IF expression IS SyntaxTree.IntegerValue THEN
int := expression(SyntaxTree.IntegerValue).hvalue;
IF (type IS SyntaxTree.IntegerType) OR (type IS SyntaxTree.SizeType) THEN
int := Global.ConvertSigned(int,system.SizeOf(type));
result := SyntaxTree.NewIntegerValue(position,int);
result.SetType(type);
ELSIF (type IS SyntaxTree.AddressType) THEN
int := Global.ConvertUnsigned(int,system.SizeOf(type));
result := SyntaxTree.NewIntegerValue(position,int);
result.SetType(type);
ELSIF (type IS SyntaxTree.FloatType) THEN
result := SyntaxTree.NewRealValue(expression.position,int);
result.SetType(type);
ELSIF (type IS SyntaxTree.ComplexType) THEN
result := SyntaxTree.NewComplexValue(expression.position, int, 0);
result.SetType(type);
ELSIF (type IS SyntaxTree.SetType) THEN
result := SyntaxTree.NewSetValue(expression.position,SYSTEM.VAL(SET,int));
result.SetType(type);
ELSIF (type IS SyntaxTree.CharacterType) OR (type IS SyntaxTree.ByteType) THEN
result := SyntaxTree.NewCharacterValue(expression.position,SYSTEM.VAL(CHAR,int));
result.SetType(type);
ELSIF (type IS SyntaxTree.EnumerationType) THEN
IF (int > MAX(LONGINT)) OR (int < MIN(LONGINT)) THEN
Error(position,Diagnostics.Invalid,"huge integer value incompatible to enumeration");
END;
result := SyntaxTree.NewEnumerationValue(expression.position,SHORT(int));
result.SetType(type);
ELSIF (type IS SyntaxTree.PortType) THEN
result := ConvertValue(position, expression, system.integerType);
ELSE
Error(position,Diagnostics.Invalid,"integer value cannot be converted");
result := SyntaxTree.invalidExpression;
IF VerboseErrorMessage THEN
Printout.Info("expression",expression);
Printout.Info("type",type);
END;
END;
ELSIF IsRealValue(expression,real) THEN
IF (type IS SyntaxTree.IntegerType) & (type.sizeInBits < 64) THEN
int := Global.ConvertSigned(ENTIER(real),system.SizeOf(type));
result := SyntaxTree.NewIntegerValue(expression.position,int);
result.SetType(type);
ELSIF (type IS SyntaxTree.IntegerType) THEN
int := ENTIERH(real);
result := SyntaxTree.NewIntegerValue(expression.position,int);
result.SetType(type);
ELSIF (type IS SyntaxTree.FloatType) THEN
result := SyntaxTree.NewRealValue(position,real);
result.SetType(type);
ELSIF (type IS SyntaxTree.ComplexType) THEN
result := SyntaxTree.NewComplexValue(expression.position, real, 0);
result.SetType(type);
result(SyntaxTree.ComplexValue).UpdateSubtype;
ELSE
Error(position,Diagnostics.Invalid,"real value cannot be converted");
result := SyntaxTree.invalidExpression;
END
ELSIF IsComplexValue(expression, real, imaginary) THEN
IF (type IS SyntaxTree.ComplexType) THEN
result := SyntaxTree.NewComplexValue(expression.position, real, imaginary);
result.SetType(type);
result(SyntaxTree.ComplexValue).SetSubtype(expression.resolved(SyntaxTree.ComplexValue).subtype)
ELSE
Error(position,Diagnostics.Invalid,"complex value cannot be converted");
result := SyntaxTree.invalidExpression;
END
ELSIF IsSetValue(expression,set) THEN
IF (type IS SyntaxTree.IntegerType) THEN
result := SyntaxTree.NewIntegerValue(expression.position,SYSTEM.VAL(LONGINT,set));
result.SetType(type);
ELSIF (type IS SyntaxTree.CharacterType) OR (type IS SyntaxTree.ByteType) THEN
result := SyntaxTree.NewCharacterValue(expression.position,SYSTEM.VAL(CHAR,set));
result.SetType(type);
ELSE
Error(position,Diagnostics.Invalid,"set value cannot be converted");
result := SyntaxTree.invalidExpression;
END;
ELSIF IsStringValue(expression,string) THEN
IF ((type IS SyntaxTree.CharacterType) OR (type IS SyntaxTree.ByteType)) & (string[1]=0X) THEN
result := SyntaxTree.NewCharacterValue(expression.position,string[0]);
result.SetType(type);
ELSIF (type IS SyntaxTree.ArrayType) & (type(SyntaxTree.ArrayType).arrayBase.resolved IS SyntaxTree.CharacterType) THEN
ELSE
Error(position,Diagnostics.Invalid,"string value cannot be converted");
result := SyntaxTree.invalidExpression;
END;
ELSIF IsCharacterValue(expression,char) THEN
IF (type IS SyntaxTree.StringType) OR (type IS SyntaxTree.ArrayType) & (type(SyntaxTree.ArrayType).arrayBase.resolved IS SyntaxTree.CharacterType) THEN
string[0] := char; string[1] := 0X;
type := SyntaxTree.NewStringType(InvalidPosition,system.characterType,2);
result := SyntaxTree.NewStringValue(expression.position,string);
result.SetType(type);
ELSIF (type IS SyntaxTree.ByteType) THEN
result := SyntaxTree.NewCharacterValue(expression.position,char);
result.SetType(type)
ELSIF (type IS SyntaxTree.IntegerType) THEN
result := SyntaxTree.NewIntegerValue(expression.position,SYSTEM.VAL(LONGINT,char));
result.SetType(type);
ELSIF (type IS SyntaxTree.SetType) THEN
result := SyntaxTree.NewSetValue(expression.position,SYSTEM.VAL(SET,char));
result.SetType(type);
ELSIF (type IS SyntaxTree.CharacterType) THEN
result := SyntaxTree.NewCharacterValue(expression.position,char);
result.SetType(type);
ELSE
Error(position,Diagnostics.Invalid,"character value cannot be converted");
result := SyntaxTree.invalidExpression;
END;
ELSIF expression IS SyntaxTree.NilValue THEN
result := expression;
ELSIF expression IS SyntaxTree.MathArrayValue THEN
result := MathArrayConversion(position, expression,type);
ELSIF expression IS SyntaxTree.EnumerationValue THEN
result := expression;
ELSE
Error(position,Diagnostics.Invalid,"expression cannot be converted");
IF VerboseErrorMessage THEN
Printout.Info("expression",expression);
Printout.Info("type",type);
END;
result := SyntaxTree.invalidExpression;
END;
RETURN result
END ConvertValue;
PROCEDURE NewConversion*(position: LONGINT; expression: SyntaxTree.Expression; type: SyntaxTree.Type; reference: SyntaxTree.Expression): SyntaxTree.Expression;
VAR result: SyntaxTree.Expression; value: SyntaxTree.Expression; expressionList: SyntaxTree.ExpressionList; typeDeclaration: SyntaxTree.TypeDeclaration; typeSymbol: SyntaxTree.Designator;
BEGIN
type := type.resolved;
ASSERT(type # NIL); ASSERT(~(type IS SyntaxTree.QualifiedType));
result := expression;
IF expression = SyntaxTree.invalidExpression THEN
ELSIF expression = NIL THEN
ELSIF expression.type = NIL THEN
Error(position,Diagnostics.Invalid,"expression of type NIL cannot be converted");
ELSIF expression.type.SameType(type) THEN
ELSIF IsPointerType(expression.type) & IsPointerType(type) THEN
ELSIF (expression.type.resolved IS SyntaxTree.AnyType) THEN
ELSIF (expression.type.resolved IS SyntaxTree.ObjectType) & (type IS SyntaxTree.AnyType) THEN
ELSIF expression.resolved # NIL THEN
value := ConvertValue(position,expression.resolved(SyntaxTree.Value),type);
IF value IS SyntaxTree.Value THEN
result := SyntaxTree.NewConversion(expression.position,expression,type,reference);
result.SetResolved(value(SyntaxTree.Value));
result.SetType(value.type);
ELSE
result := value
END;
ELSIF (type IS SyntaxTree.ByteType) THEN
expressionList := SyntaxTree.NewExpressionList();
typeDeclaration := SyntaxTree.NewTypeDeclaration(expression.position,SyntaxTree.NewIdentifier("@byte"));
typeDeclaration.SetDeclaredType(type);
typeSymbol := SyntaxTree.NewSymbolDesignator(InvalidPosition,NIL,typeDeclaration);
typeSymbol.SetType(typeDeclaration.type);
expressionList.AddExpression(typeSymbol);
expressionList.AddExpression(expression);
result := SyntaxTree.NewBuiltinCallDesignator(expression.position,Global.systemVal,NIL,expressionList);
result.SetType(type);
ELSIF IsArrayStructuredObjectType(type) THEN
HALT(100)
ELSIF (type IS SyntaxTree.MathArrayType) THEN
IF expression.type.resolved IS SyntaxTree.MathArrayType THEN
result := MathArrayConversion(position, expression,type);
ELSIF IsArrayStructuredObjectType(expression.type) THEN
expression := ConvertToMathArray(expression);
type := MathArrayStructureOfType(type);
result := MathArrayConversion(position, expression, type)
ELSE
Error(expression.position,Diagnostics.Invalid,"cannot convert non array type to array type")
END;
ELSIF (expression.type.resolved IS SyntaxTree.MathArrayType) THEN
IF (expression.type.resolved(SyntaxTree.MathArrayType).form # SyntaxTree.Static)
OR ~(type IS SyntaxTree.ArrayType) THEN
Error(expression.position,Diagnostics.Invalid,"cannot convert array type to non-array type")
END;
ELSIF ~(type IS SyntaxTree.BasicType) & ~(expression.type.resolved IS SyntaxTree.CharacterType) THEN
ELSIF (type IS SyntaxTree.ArrayType) & (type(SyntaxTree.ArrayType).arrayBase.resolved IS SyntaxTree.ByteType) THEN
ELSE
ASSERT(~(type IS SyntaxTree.RangeType));
result := SyntaxTree.NewConversion(expression.position,expression,type,reference);
ASSERT(type # NIL);
END;
RETURN result
END NewConversion;
PROCEDURE CompatibleConversion(position: LONGINT; expression: SyntaxTree.Expression; type: SyntaxTree.Type): SyntaxTree.Expression;
BEGIN
IF CompatibleTo(system,expression.type, type) THEN
RETURN NewConversion(position, expression, type, NIL);
ELSE
Error(expression.position, Diagnostics.Invalid, "incompatible expression");
RETURN SyntaxTree.invalidExpression
END;
END CompatibleConversion;
PROCEDURE ConvertOperands(VAR left,right: SyntaxTree.Expression);
VAR leftType,rightType,type: SyntaxTree.Type;
BEGIN
IF left.type = NIL THEN Error(left.position,Diagnostics.Invalid,"no type")
ELSIF right.type= NIL THEN Error(right.position,Diagnostics.Invalid,"no type")
ELSIF (left = SyntaxTree.invalidExpression) OR (right = SyntaxTree.invalidExpression) THEN
ELSE
leftType := left.type.resolved; rightType := right.type.resolved;
IF CompatibleTo(system,leftType,rightType) THEN
left := NewConversion(left.position,left,right.type.resolved,NIL);
ELSIF CompatibleTo(system,rightType,leftType) THEN
right := NewConversion(right.position,right,left.type.resolved,NIL);
ELSIF
(leftType IS SyntaxTree.ComplexType) & (rightType IS SyntaxTree.FloatType) OR
(leftType IS SyntaxTree.FloatType) & (rightType IS SyntaxTree.ComplexType) THEN
left := NewConversion(left.position, left, Global.Complex128, NIL);
right := NewConversion(right.position, right, Global.Complex128, NIL);
ELSE
Error(left.position,Diagnostics.Invalid,"incompatible operands");
END;
END;
END ConvertOperands;
PROCEDURE FindOperator*(system: Global.System; operator: LONGINT; actualParameters: SyntaxTree.ExpressionList; returnType: SyntaxTree.Type): SyntaxTree.Operator;
VAR bestOperator: SyntaxTree.Operator; bestDistance: LONGINT; import: SyntaxTree.Import; numberParameters: LONGINT; procedureType: SyntaxTree.ProcedureType;
identifier: SyntaxTree.Identifier;
PROCEDURE FindInScope(scope: SyntaxTree.ModuleScope; access: SET);
VAR operator: SyntaxTree.Operator; distance,i: LONGINT;
BEGIN
operator := scope.firstOperator;
WHILE(operator # NIL) DO
IF (operator.name=identifier) & (operator.access * access # {}) THEN
procedureType := operator.type(SyntaxTree.ProcedureType);
distance := Distance(system, procedureType,actualParameters);
IF (distance < Infinity) THEN
IF returnType # NIL THEN
IF procedureType.returnType = NIL THEN
distance := Infinity
ELSE
i := TypeDistance(system,returnType,procedureType.returnType,TRUE);
IF i = Infinity THEN distance := Infinity ELSE INC(distance,i) END;
END;
END;
END;
IF distance < bestDistance THEN
bestDistance := distance;
bestOperator := operator;
END;
END;
operator := operator.nextOperator;
END;
END FindInScope;
BEGIN
bestDistance := Infinity; bestOperator := NIL; numberParameters := actualParameters.Length();
identifier := Global.GetIdentifier(operator,currentScope.ownerModule.case);
FindInScope(currentScope.ownerModule.moduleScope,SyntaxTree.ReadOnly);
import := currentScope.ownerModule.moduleScope.firstImport;
WHILE (bestDistance > 0) & (import # NIL) DO
IF import.module # NIL THEN
identifier := Global.GetIdentifier(operator,import.module.case);
FindInScope(import.module.moduleScope,SyntaxTree.Public);
END;
import := import.nextImport;
END;
RETURN bestOperator
END FindOperator;
PROCEDURE SetCurrentScope*(scope: SyntaxTree.Scope);
BEGIN
currentScope := scope;
END SetCurrentScope;
PROCEDURE NewOperatorCall*(position: LONGINT; op: LONGINT; leftExpression, rightExpression: SyntaxTree.Expression; resultType: SyntaxTree.Type): SyntaxTree.Expression;
VAR
operator: SyntaxTree.Operator;
import: SyntaxTree.Import;
expression, result: SyntaxTree.Expression;
designator: SyntaxTree.Designator;
actualParameters, tempList: SyntaxTree.ExpressionList;
recordType: SyntaxTree.RecordType;
BEGIN
IF (leftExpression = SyntaxTree.invalidExpression) OR (rightExpression = SyntaxTree.invalidExpression) THEN
result := SyntaxTree.invalidExpression
ELSIF leftExpression = NIL THEN
result := NIL
ELSIF IsArrayStructuredObjectType(leftExpression.type) & ((op = Global.Len) OR (op = Global.Dim)) THEN
ASSERT(leftExpression.type.resolved IS SyntaxTree.PointerType);
recordType := leftExpression.type.resolved(SyntaxTree.PointerType).pointerBase.resolved(SyntaxTree.RecordType);
IF recordType.arrayAccessOperators.len = NIL THEN
Error(position, Diagnostics.Invalid, "call of undeclared LEN operator");
result := SyntaxTree.invalidExpression
ELSE
ASSERT(leftExpression IS SyntaxTree.Designator);
designator := leftExpression(SyntaxTree.Designator);
expression := NewSymbolDesignator(InvalidPosition, NewDereferenceDesignator(position, designator), recordType.arrayAccessOperators.len);
ASSERT(expression IS SyntaxTree.Designator);
designator := NewProcedureCallDesignator(InvalidPosition, expression(SyntaxTree.Designator), SyntaxTree.NewExpressionList());
IF (op = Global.Len) & (rightExpression = NIL) THEN
result := designator
ELSIF (op = Global.Len) & (rightExpression # NIL) & (rightExpression.type.resolved IS SyntaxTree.IntegerType) THEN
tempList := SyntaxTree.NewExpressionList();
tempList.AddExpression(rightExpression);
result := ResolveDesignator(SyntaxTree.NewBracketDesignator(InvalidPosition, designator, tempList))
ELSIF (op = Global.Dim) & (rightExpression = NIL) THEN
tempList := SyntaxTree.NewExpressionList();
tempList.AddExpression(designator);
tempList.AddExpression(SyntaxTree.NewIntegerValue(InvalidPosition, 0));
designator := SyntaxTree.NewIdentifierDesignator(InvalidPosition, Global.GetIdentifier(Global.Len, module.case));
result := ResolveExpression(SyntaxTree.NewParameterDesignator(InvalidPosition, designator, tempList))
END
END;
ELSE
IF ~arrayBaseImported THEN
IF (leftExpression # NIL) & IsComplexType(leftExpression.type) THEN
ImportModule(Global.ArrayBaseName,position);
arrayBaseImported := TRUE;
ELSIF (leftExpression # NIL) & IsMathArrayType(leftExpression.type) OR (rightExpression # NIL) & IsMathArrayType(rightExpression.type) THEN
IF op = Global.Dim THEN
ELSIF (op = Global.Len) & (rightExpression # NIL) THEN
ELSE
ImportModule(Global.ArrayBaseName,position);
arrayBaseImported := TRUE;
END
ELSIF (leftExpression # NIL) & IsArrayStructuredObjectType(leftExpression.type) OR (rightExpression # NIL) & IsArrayStructuredObjectType(rightExpression.type) THEN
ImportModule(Global.ArrayBaseName,position);
arrayBaseImported := TRUE
END;
IF (op = Global.Len) & (leftExpression # NIL) & IsRangeType(leftExpression.type) & (rightExpression = NIL) THEN
ImportModule(Global.ArrayBaseName,position);
arrayBaseImported := TRUE;
END;
END;
actualParameters := SyntaxTree.NewExpressionList();
actualParameters.AddExpression(leftExpression);
IF rightExpression # NIL THEN
actualParameters.AddExpression(rightExpression)
END;
operator := FindOperator(system,op,actualParameters,resultType);
IF operator # NIL THEN
designator := NIL;
IF operator.scope.ownerModule # currentScope.ownerModule THEN
import := currentScope.ownerModule.moduleScope.firstImport;
WHILE(import # NIL) & (import.module # operator.scope.ownerModule) DO
import := import.nextImport;
END;
expression := NewSymbolDesignator(position,NIL,import);
designator := expression(SyntaxTree.Designator);
END;
expression := NewSymbolDesignator(position,designator,operator);
designator := expression(SyntaxTree.Designator);
result := NewProcedureCallDesignator(position,designator,actualParameters);
ELSE
result := NIL;
END;
END;
RETURN result
END NewOperatorCall;
PROCEDURE VisitBinaryExpression(binaryExpression: SyntaxTree.BinaryExpression);
VAR left,right,result: SyntaxTree.Expression;
leftType, rightType: SyntaxTree.Type;
il,ir: LONGINT; rl,rr,a,b,c,d,divisor: LONGREAL; hl,hr: HUGEINT;bl,br: BOOLEAN; sl,sr: SET; strl,strr: Scanner.StringType;
cl,cr: CHAR;
operator: LONGINT; operatorCall: SyntaxTree.Expression;
type: SyntaxTree.Type;
value: SyntaxTree.Value;
leftFirst, leftLast, leftStep, rightFirst, rightLast, rightStep: LONGINT;
PROCEDURE NewBool(v: BOOLEAN);
BEGIN
value := SyntaxTree.NewBooleanValue(binaryExpression.position,v);
value.SetType(system.booleanType);
result.SetResolved(value);
type := system.booleanType
END NewBool;
PROCEDURE NewSet(v: SET);
BEGIN
value := SyntaxTree.NewSetValue(binaryExpression.position,v);
value.SetType(system.setType);
result.SetResolved(value);
type := system.setType;
END NewSet;
PROCEDURE NewInteger(v: HUGEINT; t: SyntaxTree.Type);
BEGIN
value := Global.NewIntegerValue(system,binaryExpression.position,v);
result.SetResolved(value);
type := value.type;
END NewInteger;
PROCEDURE NewReal(v: LONGREAL; t: SyntaxTree.Type);
BEGIN
value := SyntaxTree.NewRealValue(binaryExpression.position,v);
value.SetType(t);
result.SetResolved(value);
type := t;
END NewReal;
PROCEDURE NewComplex(realValue, imagValue: LONGREAL; t: SyntaxTree.Type);
BEGIN
value := SyntaxTree.NewComplexValue(binaryExpression.position, realValue, imagValue);
value.SetType(t);
value(SyntaxTree.ComplexValue).UpdateSubtype;
result.SetResolved(value);
type := t;
END NewComplex;
BEGIN
type := SyntaxTree.invalidType;
left := ResolveExpression(binaryExpression.left);
right := ResolveExpression(binaryExpression.right);
binaryExpression.SetLeft(left);
binaryExpression.SetRight(right);
result := binaryExpression;
operator := binaryExpression.operator;
IF ~system.operatorDefined[operator] THEN
Error(left.position,Diagnostics.Invalid,"Operator Not Defined");
result := SyntaxTree.invalidExpression;
RETURN
END;
IF left.type = NIL THEN
Error(left.position,Diagnostics.Invalid,"Expression has no result type");
result := SyntaxTree.invalidExpression;
RETURN;
END;
IF right.type = NIL THEN
Error(right.position,Diagnostics.Invalid,"Expression has no result type");
result := SyntaxTree.invalidExpression;
RETURN;
END;
leftType := left.type.resolved; rightType := right.type.resolved;
IF ~(leftType IS SyntaxTree.BasicType) OR ~(rightType IS SyntaxTree.BasicType) OR (leftType IS SyntaxTree.ComplexType) OR (rightType IS SyntaxTree.ComplexType) THEN
operatorCall := NewOperatorCall(binaryExpression.position,operator,left,right,NIL);
END;
IF operatorCall # NIL THEN
result := operatorCall;
type := operatorCall.type;
ELSIF (left.type = NIL) THEN
Error(left.position,Diagnostics.Invalid,"type (left operand) = NIL in binary expression");
D.Str("nil type in "); D.Type(left); D.Ln;
result := SyntaxTree.invalidExpression;
ELSIF (right.type = NIL) THEN
Error(right.position,Diagnostics.Invalid,"type (right operand) = NIL in binary expression");
result := SyntaxTree.invalidExpression;
ELSIF (leftType = SyntaxTree.invalidType) OR (rightType = SyntaxTree.invalidType) THEN
result := SyntaxTree.invalidExpression;
ELSIF operator = Scanner.Upto THEN
HALT(100);
ELSIF operator = Scanner.Is THEN
type := system.booleanType;
IF ~(rightType = SyntaxTree.typeDeclarationType) THEN
Error(right.position,Diagnostics.Invalid,"is not a type ");
ELSIF ~IsTypeExtension(leftType, right(SyntaxTree.SymbolDesignator).symbol(SyntaxTree.TypeDeclaration).declaredType.resolved) THEN
Error(binaryExpression.position,Diagnostics.Invalid,"is not a type extension of ");
IF VerboseErrorMessage THEN
Printout.Info("left",left);
Printout.Info("right",right);
END;
ELSIF (leftType.SameType(right(SyntaxTree.SymbolDesignator).symbol(SyntaxTree.TypeDeclaration).declaredType.resolved)) & ~(leftType IS SyntaxTree.PointerType) THEN
NewBool(TRUE)
ELSIF right(SyntaxTree.SymbolDesignator).symbol(SyntaxTree.TypeDeclaration).declaredType.resolved IS SyntaxTree.AnyType THEN
NewBool(TRUE);
ELSIF IsUnextensibleRecord(left) THEN
NewBool(FALSE)
END
ELSIF (right IS SyntaxTree.SymbolDesignator) & (right(SyntaxTree.SymbolDesignator).symbol IS SyntaxTree.TypeDeclaration) THEN
Error(right.position,Diagnostics.Invalid,"must not be a type");
ELSIF operator = Scanner.In THEN
IF IsIntegerType(leftType) & (rightType IS SyntaxTree.SetType) THEN
IF IsIntegerValue(left,il) & IsSetValue(right,sr) THEN
NewBool(il IN sr);
ELSE
IF leftType.sizeInBits # system.longintType.sizeInBits THEN
left := NewConversion(left.position, left, system.longintType,NIL);
binaryExpression.SetLeft(left)
END;
type := system.booleanType;
END
ELSE
Error(binaryExpression.position,Diagnostics.Invalid, "incompatible operands");
END
ELSIF (leftType IS SyntaxTree.ProcedureType) OR (rightType IS SyntaxTree.ProcedureType) THEN
IF ~CompatibleTo(system,leftType,rightType) & ~CompatibleTo(system,rightType,leftType) THEN
Error(binaryExpression.position,Diagnostics.Invalid,"incompatible operands");
END;
IF (operator = Scanner.Equal) OR (operator = Scanner.Unequal) THEN type := system.booleanType
ELSE Error(binaryExpression.position,Diagnostics.Invalid,"operator not defined 1")
END
ELSIF IsPointerType(leftType) OR IsPointerType(rightType) THEN
IF ~CompatibleTo(system,leftType,rightType) & ~CompatibleTo(system,rightType,leftType) THEN
Error(binaryExpression.position,Diagnostics.Invalid,"incompatible operands");
IF VerboseErrorMessage THEN Printout.Info("leftType",leftType); Printout.Info("right",rightType) END
ELSIF (operator = Scanner.Equal) OR (operator = Scanner.Unequal) THEN
IF (left IS SyntaxTree.NilValue) & (right IS SyntaxTree.NilValue) THEN
IF operator = Scanner.Equal THEN NewBool(TRUE) ELSE NewBool(FALSE) END;
END;
type := system.booleanType;
ELSE
Error(binaryExpression.position,Diagnostics.Invalid,"operator not defined 3");
END
ELSIF (left.resolved# NIL) & (left.resolved IS SyntaxTree.NilValue) THEN Error(binaryExpression.position,Diagnostics.Invalid,"operator not defined");
ELSIF (right.resolved # NIL) & (right.resolved IS SyntaxTree.NilValue) THEN Error(binaryExpression.position,Diagnostics.Invalid,"operator not defined");
ELSIF IsStringType(leftType) & IsStringType(rightType) THEN
IF IsStringType(leftType) & IsStringType(rightType) THEN
IF IsStringValue(left,strl) & IsStringValue(right,strr) THEN
CASE operator OF
|Scanner.Equal: NewBool(strl^=strr^);
|Scanner.Unequal:NewBool(strl^#strr^);
|Scanner.Less: NewBool(strl^<strr^);
|Scanner.LessEqual: NewBool(strl^<=strr^);
|Scanner.Greater: NewBool(strl^>strr^);
|Scanner.GreaterEqual: NewBool(strl^>=strr^);
ELSE
Error(binaryExpression.position,Diagnostics.Invalid,"operator not defined 4");
END;
END;
ELSIF (operator = Scanner.Equal) OR (operator=Scanner.Unequal) OR (operator = Scanner.Less)
OR (operator = Scanner.LessEqual) OR (operator = Scanner.Greater) OR (operator = Scanner.GreaterEqual) THEN
type := system.booleanType
ELSE
Error(binaryExpression.position,Diagnostics.Invalid,"operator not defined 5");
END;
IF (operator = Scanner.Equal) OR (operator=Scanner.Unequal)
OR (operator = Scanner.Less) OR (operator = Scanner.LessEqual)
OR (operator = Scanner.Greater) OR (operator = Scanner.GreaterEqual) THEN
type := system.booleanType;
ELSE
Error(binaryExpression.position,Diagnostics.Invalid,"operator not defined 6");
END
ELSIF (leftType IS SyntaxTree.EnumerationType) OR (rightType IS SyntaxTree.EnumerationType) THEN
IF IsEnumerationExtension(left.type,right.type) OR IsEnumerationExtension(right.type,left.type) THEN
IF (operator = Scanner.Equal) OR (operator = Scanner.Unequal) OR (operator = Scanner.Less) OR (operator = Scanner.LessEqual)
OR (operator = Scanner.Greater) OR (operator = Scanner.GreaterEqual) THEN
type := system.booleanType
ELSE
Error(binaryExpression.position,Diagnostics.Invalid,"operator not defined for enumerators");
END;
ELSE
Error(binaryExpression.position,Diagnostics.Invalid,"operator not applicable between different enumerators");
END;
ELSIF (leftType IS SyntaxTree.BasicType) & (rightType IS SyntaxTree.BasicType)
OR IsCharacterType(leftType) & IsCharacterType(rightType)
THEN
IF leftType # rightType THEN
ConvertOperands(left,right);
binaryExpression.SetLeft(left);
binaryExpression.SetRight(right);
leftType := left.type.resolved;
rightType := right.type.resolved;
END;
type := leftType;
IF ~leftType.SameType(rightType) THEN
Error(binaryExpression.position,Diagnostics.Invalid,"conversion failed ?");
IF VerboseErrorMessage THEN
Printout.Info("left",left);
Printout.Info("right",right);
END;
ELSIF IsIntegerType(leftType) THEN
IF IsIntegerValue(right,ir) THEN
hr := right.resolved(SyntaxTree.IntegerValue).hvalue;
IF (hr=0) & ((operator = Scanner.Mod) OR (operator = Scanner.Div) OR (operator = Scanner.Slash)) THEN
Error(binaryExpression.position,Diagnostics.Invalid,"division by zero");
ELSIF (hr<0) & ((operator = Scanner.Mod) OR (operator = Scanner.Div))THEN
Error(binaryExpression.position,Diagnostics.Invalid,"integer division by negative number");
END;
END;
IF IsIntegerValue(left,il) & IsIntegerValue(right,ir) THEN
hl := left.resolved(SyntaxTree.IntegerValue).hvalue;
hr := right.resolved(SyntaxTree.IntegerValue).hvalue;
CASE operator OF
|Scanner.Plus: NewInteger(hl+hr,left.type);
|Scanner.Minus: NewInteger(hl-hr,left.type);
|Scanner.Times: NewInteger(hl*hr,left.type);
|Scanner.Slash:
IF hr = 0 THEN
Error(binaryExpression.position,Diagnostics.Invalid,"division by zero");
ELSE
IF type.sizeInBits = 64 THEN
NewReal(hl/hr,system.longrealType);
ELSE
NewReal(hl/hr,system.realType)
END
END;
|Scanner.Mod:
IF hr = 0 THEN
Error(binaryExpression.position,Diagnostics.Invalid,"division by zero");
ELSE
NewInteger(hl MOD hr, left.type);
END;
|Scanner.Div:
IF hr = 0 THEN
Error(binaryExpression.position,Diagnostics.Invalid,"division by zero");
ELSE
NewInteger(hl DIV hr, left.type);
END;
|Scanner.Equal: NewBool(hl=hr);
|Scanner.Unequal: NewBool(hl#hr);
|Scanner.Less: NewBool(hl<hr);
|Scanner.LessEqual: NewBool(hl<=hr);
|Scanner.Greater: NewBool(hl>hr);
|Scanner.GreaterEqual:NewBool(hl>=hr);
ELSE Error(binaryExpression.position,Diagnostics.Invalid,"operator not defined 8");
END;
ELSIF (operator = Scanner.Plus) OR (operator = Scanner.Minus) OR (operator = Scanner.Times) OR
(operator = Scanner.Mod) OR (operator = Scanner.Div) THEN
type := left.type
ELSIF (operator = Scanner.Slash) THEN
left := NewConversion(left.position,left,system.realType,NIL);
right := NewConversion(right.position,right,system.realType,NIL);
binaryExpression.SetLeft(left);
binaryExpression.SetRight(right);
type := system.realType
ELSIF (operator = Scanner.Equal) OR (operator = Scanner.Unequal) OR (operator = Scanner.Less) OR (operator = Scanner.LessEqual)
OR (operator = Scanner.Greater) OR (operator = Scanner.GreaterEqual) THEN
type := system.booleanType
ELSE
Error(binaryExpression.position,Diagnostics.Invalid,"operator not defined 9");
END;
ELSIF (leftType IS SyntaxTree.FloatType) THEN
IF IsRealValue(left,rl) & IsRealValue(right,rr) THEN
CASE operator OF
|Scanner.Plus: NewReal(rl+rr,leftType);
|Scanner.Minus: NewReal(rl-rr,leftType);
|Scanner.Times:NewReal(rl*rr,leftType);
|Scanner.Slash:
IF rr = 0 THEN
Error(binaryExpression.position,Diagnostics.Invalid,"division by zero");
ELSE
NewReal(rl/rr,leftType);
END
|Scanner.Equal: NewBool(rl=rr);
|Scanner.Unequal: NewBool(rl#rr);
|Scanner.Less: NewBool(rl<rr);
|Scanner.LessEqual: NewBool(rl<=rr);
|Scanner.Greater: NewBool(rl>rr);
|Scanner.GreaterEqual: NewBool(rl>=rr);
ELSE Error(binaryExpression.position,Diagnostics.Invalid,"operator not defined 10");
END;
ELSIF (operator = Scanner.Plus) OR (operator = Scanner.Minus) OR (operator = Scanner.Times) OR (operator = Scanner.Slash) THEN
type := left.type
ELSIF (operator = Scanner.Equal) OR (operator = Scanner.Unequal) OR (operator = Scanner.Less) OR (operator = Scanner.LessEqual)
OR (operator = Scanner.Greater) OR (operator = Scanner.GreaterEqual) THEN
type := system.booleanType
ELSE
Error(binaryExpression.position,Diagnostics.Invalid,"operator not defined 11");
IF VerboseErrorMessage THEN
Printout.Info("left",left);
Printout.Info("right",right);
END;
END;
ELSIF (leftType IS SyntaxTree.ComplexType) THEN
CASE operator OF
|Scanner.Plus, Scanner.Minus, Scanner.Times, Scanner.Slash: type := left.type
|Scanner.Equal, Scanner.Unequal: type := system.booleanType
ELSE
Error(binaryExpression.position, Diagnostics.Invalid,"operator not defined");
IF VerboseErrorMessage THEN
Printout.Info("left", left);
Printout.Info("right", right)
END;
END;
IF ~error THEN
IF (operator = Scanner.Slash) & IsComplexValue(right, c, d) & (c = 0) & (d = 0) THEN
Error(binaryExpression.position, Diagnostics.Invalid,"division by zero")
ELSIF IsComplexValue(left, a, b) & IsComplexValue(right, c, d) THEN
CASE operator OF
|Scanner.Plus: NewComplex(a + b, c + d, leftType)
|Scanner.Minus: NewComplex(a - b, c - d, leftType)
|Scanner.Times: NewComplex(a * c - b * d, b * c + a * d, leftType)
|Scanner.Slash:
divisor := c * c + d * d;
ASSERT(divisor # 0);
NewComplex((a * c + b * d) / divisor, (b * c - a * d) / divisor, leftType)
|Scanner.Equal: NewBool((a = c) & (b = d))
|Scanner.Unequal: NewBool((a # c) OR (b # d))
END
END
END
ELSIF (leftType IS SyntaxTree.BooleanType) THEN
IF IsBooleanValue(left,bl) & IsBooleanValue(right,br) THEN
CASE operator OF
|Scanner.And: NewBool(bl & br);
|Scanner.Or: NewBool(bl OR br);
|Scanner.Equal: NewBool(bl = br);
|Scanner.Unequal: NewBool(bl # br);
ELSE Error(binaryExpression.position,Diagnostics.Invalid,"operator not defined 12");
END;
ELSIF (operator = Scanner.Equal) OR (operator = Scanner.Unequal) OR (operator = Scanner.And) OR (operator = Scanner.Or) THEN
type := system.booleanType
ELSE
Error(binaryExpression.position,Diagnostics.Invalid,"operator not defined 13");
END;
ELSIF left.type.resolved IS SyntaxTree.RangeType THEN
IF IsStaticRange(left, leftFirst, leftLast, leftStep) & IsStaticRange(right, rightFirst, rightLast, rightStep) THEN
IF operator = Scanner.Equal THEN
NewBool((leftFirst = rightFirst) & (leftLast = rightLast) & (leftStep = rightStep))
ELSIF operator = Scanner.Unequal THEN
NewBool((leftFirst # rightFirst) OR (leftLast # rightLast) OR (leftStep # rightStep))
END;
END;
IF (operator = Scanner.Equal) OR (operator = Scanner.Unequal) THEN
type := system.booleanType;
ELSE
Error(binaryExpression.position, Diagnostics.Invalid, "operator not defined");
END;
ELSIF (leftType IS SyntaxTree.SetType) THEN
IF IsSetValue(left,sl) & IsSetValue(right,sr) THEN
CASE operator OF
|Scanner.Plus: NewSet(sl + sr);
|Scanner.Minus: NewSet(sl - sr);
|Scanner.Times: NewSet(sl * sr);
|Scanner.Slash: NewSet(sl / sr);
|Scanner.Equal: NewBool(sl=sr);
|Scanner.Unequal: NewBool(sl#sr);
|Scanner.Less: NewBool( (sl * sr = sl) & (sl#sr));
|Scanner.LessEqual: NewBool(sl*sr = sl);
|Scanner.Greater: NewBool( (sl * sr = sr) & (sl # sr));
|Scanner.GreaterEqual: NewBool(sl*sr = sr);
ELSE Error(binaryExpression.position,Diagnostics.Invalid,"operator not defined 14");
END;
ELSIF (operator = Scanner.Equal) OR (operator = Scanner.Unequal)
OR (operator = Scanner.Less) OR (operator = Scanner.LessEqual)
OR (operator = Scanner.Greater) OR (operator = Scanner.GreaterEqual)
THEN
type := system.booleanType
ELSIF (operator = Scanner.Plus) OR (operator = Scanner.Minus) OR (operator = Scanner.Times) OR (operator = Scanner.Slash) THEN
type := left.type
ELSE
Error(binaryExpression.position,Diagnostics.Invalid,"operator not defined 15");
END;
ELSIF IsCharacterType(left.type) THEN
IF IsCharacterValue(left,cl) & IsCharacterValue(right,cr) THEN
CASE operator OF
|Scanner.Equal: NewBool(cl=cr);
|Scanner.Unequal: NewBool(cl#cr);
|Scanner.Less: NewBool(cl<cr);
|Scanner.LessEqual: NewBool(cl<=cr);
|Scanner.Greater: NewBool(cl>cr);
|Scanner.GreaterEqual: NewBool(cl>=cr);
ELSE Error(binaryExpression.position,Diagnostics.Invalid,"operator not defined 16");
END;
ELSIF (operator = Scanner.Equal) OR (operator = Scanner.Unequal) OR (operator = Scanner.Less) OR (operator = Scanner.LessEqual)
OR (operator = Scanner.Greater) OR (operator = Scanner.GreaterEqual) THEN
type := system.booleanType
ELSE
Error(binaryExpression.position,Diagnostics.Invalid,"operator not defined 17");
END;
ELSE
Error(binaryExpression.position,Diagnostics.Invalid,"operator not defined 18");
END;
ELSE
Error(binaryExpression.position,Diagnostics.Invalid,"operator not defined 19");
END;
IF type = SyntaxTree.invalidType THEN
result := SyntaxTree.invalidExpression
ELSE
result.SetType(type)
END;
resolvedExpression := result
END VisitBinaryExpression;
PROCEDURE VisitRangeExpression(x: SyntaxTree.RangeExpression);
VAR
hasError: BOOLEAN;
first, last, step: SyntaxTree.Expression;
BEGIN
hasError := FALSE;
first := x.first;
last := x.last;
step := x.step;
IF x.context = SyntaxTree.CaseGuard THEN
IF first = NIL THEN
Error(x.position, Diagnostics.Invalid, "missing lower bound");
hasError := TRUE
ELSE
first := ResolveExpression(first);
IF ~(first.type.resolved IS SyntaxTree.IntegerType) & ~IsCharacterType(first.type.resolved) THEN
Error(first.position, Diagnostics.Invalid, "lower bound not integer or character");
hasError := TRUE
ELSE
IF first IS SyntaxTree.StringValue THEN
first := ConvertValue(first.position, first(SyntaxTree.Value), system.characterType)
END
END;
IF ConstantExpression(first) = SyntaxTree.invalidExpression THEN
hasError := TRUE
END
END
ELSE
IF first = NIL THEN
first := SyntaxTree.NewIntegerValue(x.position, 0);
END;
first := ResolveExpression(first);
IF first.type.resolved IS SyntaxTree.IntegerType THEN
first := NewConversion(first.position, first, system.longintType, NIL)
ELSE
Error(first.position, Diagnostics.Invalid, "lower bound not integer");
hasError := TRUE
END
END;
IF x.context = SyntaxTree.CaseGuard THEN
IF last = NIL THEN
Error(x.position, Diagnostics.Invalid, "missing upper bound");
hasError := TRUE
ELSE
last := ResolveExpression(last);
IF ~(last.type.resolved IS SyntaxTree.IntegerType) & ~IsCharacterType(last.type.resolved) THEN
Error(last.position, Diagnostics.Invalid, "lower bound not integer or character");
hasError := TRUE
ELSE
IF last IS SyntaxTree.StringValue THEN
last := ConvertValue(last.position, last(SyntaxTree.Value), system.characterType)
END
END;
IF ConstantExpression(last) = SyntaxTree.invalidExpression THEN
hasError := TRUE
ELSE
ConvertOperands(first, last);
IF first.type.resolved # last.type.resolved THEN
Error(x.position, Diagnostics.Invalid, "lower and upper bounds incompatible");
hasError := TRUE
END
END
END
ELSE
IF last = NIL THEN
IF x.context = SyntaxTree.ArrayIndex THEN
last := SyntaxTree.NewIntegerValue(x.position, MAX(LONGINT))
ELSE
last := SyntaxTree.NewIntegerValue(x.position, MAX(SET))
END
END;
last := ResolveExpression(last);
IF last.type.resolved IS SyntaxTree.IntegerType THEN
last := NewConversion(last.position, last, system.longintType, NIL)
ELSE
Error(last.position, Diagnostics.Invalid, "upper bound not integer");
hasError := TRUE
END
END;
IF x.context = SyntaxTree.ArrayIndex THEN
IF step = NIL THEN
step := SyntaxTree.NewIntegerValue(x.position, 1)
END;
step := ResolveExpression(step);
IF step.type.resolved IS SyntaxTree.IntegerType THEN
step := NewConversion(step.position, step, system.longintType, NIL)
ELSE
Error(step.position, Diagnostics.Invalid, "step size not integer");
hasError := TRUE
END
ELSE
IF step # NIL THEN
Error(last.position, Diagnostics.Invalid, "step size not allowed in this context");
hasError := TRUE
END
END;
IF hasError THEN
resolvedExpression := SyntaxTree.invalidExpression
ELSE
x.SetFirst(first);
x.SetLast(last);
x.SetStep(step);
x.SetType(system.rangeType);
resolvedExpression := x;
resolvedExpression.SetAssignable(FALSE)
END
END VisitRangeExpression;
PROCEDURE VisitTensorRangeExpression(x: SyntaxTree.TensorRangeExpression);
BEGIN
x.SetType(NIL);
resolvedExpression := x;
END VisitTensorRangeExpression;
PROCEDURE ResolveDesignator*(d: SyntaxTree.Expression): SyntaxTree.Designator;
VAR result: SyntaxTree.Designator; resolved: SyntaxTree.Expression;
BEGIN
IF Trace THEN D.Str("ResolveDesignator"); D.Ln; END;
resolved := ResolveExpression(d);
IF resolved = SyntaxTree.invalidExpression THEN
result := SyntaxTree.invalidDesignator;
ELSIF resolved IS SyntaxTree.Designator THEN
result := resolved(SyntaxTree.Designator)
ELSE
Error(d.position,Diagnostics.Invalid,"is no designator ! ");
result := SyntaxTree.invalidDesignator;
END;
RETURN result
END ResolveDesignator;
PROCEDURE VisitSymbolDesignator(x: SyntaxTree.SymbolDesignator);
BEGIN
resolvedExpression := x;
END VisitSymbolDesignator;
PROCEDURE VisitSelfDesignator(x: SyntaxTree.SelfDesignator);
VAR scope: SyntaxTree.Scope; record: SyntaxTree.RecordType; type: SyntaxTree.Type; cell: SyntaxTree.CellType;
BEGIN
scope := currentScope;
WHILE (scope # NIL) & ~(scope IS SyntaxTree.RecordScope) &~(scope IS SyntaxTree.CellScope) DO
scope := scope.outerScope;
END;
IF scope = NIL THEN
x.SetType(system.anyType);
ELSIF scope IS SyntaxTree.CellScope THEN
cell := scope(SyntaxTree.CellScope).ownerCell;
x.SetType(cell);
ELSE
record := scope(SyntaxTree.RecordScope).ownerRecord;
IF (record # NIL) & (record.pointerType # NIL) THEN
type := ResolveType(record.pointerType);
x.SetType(type);
ELSE
x.SetType(record);
END;
END;
resolvedExpression := x;
END VisitSelfDesignator;
PROCEDURE VisitResultDesignator(x: SyntaxTree.ResultDesignator);
VAR scope: SyntaxTree.Scope; procedure: SyntaxTree.Procedure; procedureType: SyntaxTree.ProcedureType; returnType: SyntaxTree.Type;
BEGIN
scope := currentScope;
IF (scope # NIL) & (scope IS SyntaxTree.ProcedureScope) THEN
procedure := scope(SyntaxTree.ProcedureScope).ownerProcedure;
procedureType := procedure.type(SyntaxTree.ProcedureType);
returnType := procedureType.returnType;
IF IsPointerType(returnType) OR IsArrayType(returnType) OR IsMathArrayType(returnType)
THEN
x.SetType(returnType);
ELSE
Error(x.position,Diagnostics.Invalid,"forbidden access to result designator (only pointer, array and math array)");
x.SetType(SyntaxTree.invalidType);
END;
ELSE
Error(x.position,Diagnostics.Invalid,"forbidden access to result designator");
x.SetType(SyntaxTree.invalidType);
END;
x.SetAssignable(TRUE);
resolvedExpression := x;
END VisitResultDesignator;
PROCEDURE NewSymbolDesignator*(position: LONGINT; left: SyntaxTree.Designator; symbol: SyntaxTree.Symbol): SyntaxTree.Expression;
VAR result: SyntaxTree.Expression; assignable: BOOLEAN; scope: SyntaxTree.Scope;
guardType: SyntaxTree.Type;
BEGIN
IF Trace THEN D.Str("NewSymbolDesignator "); D.Ln; END;
result := SyntaxTree.invalidExpression;
ASSERT(symbol # NIL);
IF (left = NIL) & (symbol.scope IS SyntaxTree.RecordScope) THEN
left := ResolveDesignator(SyntaxTree.NewSelfDesignator(position));
IF IsPointerType(left.type) THEN
left := NewDereferenceDesignator(position,left)
END;
ELSIF (symbol.scope IS SyntaxTree.ProcedureScope) THEN
scope := currentScope;
WHILE (scope # NIL) & (scope # symbol.scope) & ~(scope IS SyntaxTree.RecordScope) DO
scope := scope.outerScope;
END;
IF (scope # NIL) & (scope # symbol.scope) & ~(symbol IS SyntaxTree.Constant) THEN
Error(position,Diagnostics.Invalid,"forbidden access to symbol in parent procedure scope");
END;
END;
assignable := (left = NIL) OR left.assignable OR (left IS SyntaxTree.DereferenceDesignator) OR (left IS SyntaxTree.SelfDesignator);
IF (currentScope # NIL) & (symbol.scope.ownerModule # currentScope.ownerModule) THEN
assignable := assignable & (SyntaxTree.PublicWrite IN symbol.access);
ELSE
assignable := assignable & (SyntaxTree.InternalWrite IN symbol.access);
END;
result := SyntaxTree.NewSymbolDesignator(position,left,symbol);
result.SetType(symbol.type);
result.SetAssignable(assignable);
symbol.MarkUsed;
IF symbol IS SyntaxTree.Constant THEN
result.SetResolved(symbol(SyntaxTree.Constant).value.resolved);
END;
IF (left = NIL) OR (left IS SyntaxTree.SelfDesignator) OR (left IS SyntaxTree.DereferenceDesignator) & (left(SyntaxTree.DereferenceDesignator).left IS SyntaxTree.SelfDesignator) THEN
IF GetGuard(symbol,guardType) THEN
result := NewTypeGuardDesignator(position,result(SyntaxTree.SymbolDesignator),guardType);
END;
END;
ASSERT(result.type # NIL);
RETURN result
END NewSymbolDesignator;
PROCEDURE VisitIdentifierDesignator(identifierDesignator: SyntaxTree.IdentifierDesignator);
VAR symbol: SyntaxTree.Symbol;
BEGIN
IF Trace THEN D.Str("VisitIdentifierDesignator "); D.Ln; END;
symbol := Find(currentScope,identifierDesignator.identifier,TRUE);
IF symbol # NIL THEN
ResolveSymbol(symbol);
ASSERT(symbol.type # NIL);
resolvedExpression := NewSymbolDesignator(identifierDesignator.position,NIL,symbol);
ELSE
Error(identifierDesignator.position,Basic.UndeclaredIdentifier,"");
IF VerboseErrorMessage THEN
Printout.Info("undeclared identifier designator",identifierDesignator);
END;
resolvedExpression := SyntaxTree.invalidDesignator;
END;
END VisitIdentifierDesignator;
PROCEDURE VisitSelectorDesignator(selectorDesignator: SyntaxTree.SelectorDesignator);
VAR
symbol: SyntaxTree.Symbol; left: SyntaxTree.Designator; scope: SyntaxTree.Scope;
module: SyntaxTree.Module; result: SyntaxTree.Expression; type: SyntaxTree.Type;
BEGIN
IF Trace THEN D.Str("VisitSelectorDesignator"); D.Ln; END;
left := ResolveDesignator(selectorDesignator.left);
result := SyntaxTree.invalidDesignator;
IF left # NIL THEN
IF (left.type # NIL) & IsPointerType(left.type.resolved) THEN
left := NewDereferenceDesignator(selectorDesignator.position,left);
END;
scope := NIL;
IF left.type = NIL THEN
Error(selectorDesignator.position,Diagnostics.Invalid,"field on nil typed designator");
IF VerboseErrorMessage THEN Printout.Info("nil typed designator",left) END;
ELSIF left.type.resolved = SyntaxTree.invalidType THEN
ELSIF left.type.resolved = SyntaxTree.importType THEN
symbol := left(SyntaxTree.SymbolDesignator).symbol;
module := symbol(SyntaxTree.Import).module;
IF module # NIL THEN
scope := module.moduleScope
ELSE
Error(left.position,Diagnostics.Invalid,"module not loaded");
IF VerboseErrorMessage THEN Printout.Info("unloaded module",symbol) END;
END;
ELSIF left.type.resolved IS SyntaxTree.RecordType THEN
scope := left.type.resolved(SyntaxTree.RecordType).recordScope;
ASSERT(scope # NIL)
ELSIF left.type.resolved = SyntaxTree.typeDeclarationType THEN
symbol := left(SyntaxTree.SymbolDesignator).symbol;
type := symbol(SyntaxTree.TypeDeclaration).declaredType.resolved;
IF type IS SyntaxTree.EnumerationType THEN
scope := type(SyntaxTree.EnumerationType).enumerationScope;
ELSE
Error(selectorDesignator.position,Diagnostics.Invalid,"field on non-enumeration type declaration");
IF VerboseErrorMessage THEN Printout.Info("non-record type designator",left) END;
END;
ELSIF left.type.resolved IS SyntaxTree.CellType THEN
scope := left.type.resolved(SyntaxTree.CellType).cellScope;
ELSE
Error(selectorDesignator.position,Diagnostics.Invalid,"field on non-record type designator");
IF VerboseErrorMessage THEN Printout.Info("non-record type designator",left) END;
END;
symbol := NIL;
IF scope # NIL THEN
symbol := Find(scope,selectorDesignator.identifier,FALSE );
IF symbol # NIL THEN
ResolveSymbol(symbol);
result := NewSymbolDesignator(selectorDesignator.position,left,symbol);
symbol.MarkUsed
ELSE
Error(selectorDesignator.position,Diagnostics.Invalid,"undeclared identifier (selector)");
IF VerboseErrorMessage THEN
Printout.Info("undeclared identifier",selectorDesignator);
Printout.Info("left resolved designator",left);
END
END;
END;
END;
resolvedExpression := result;
END VisitSelectorDesignator;
PROCEDURE IndexCheck(index,length: SyntaxTree.Expression);
VAR len,idx: LONGINT;
BEGIN
IF (index # NIL) & IsIntegerValue(index,idx) THEN
IF idx < 0 THEN
Error(index.position,Diagnostics.Invalid,"index out of bounds (too small)")
ELSE
IF (length # NIL) & IsIntegerValue(length,len) & (idx >= len) THEN
Error(index.position,Diagnostics.Invalid,"index out of bounds (too large)");
END;
END;
END;
END IndexCheck;
PROCEDURE SetIndexBaseType(indexDesignator: SyntaxTree.IndexDesignator; newBaseType: SyntaxTree.Type);
VAR
mathArrayType: SyntaxTree.MathArrayType;
makeDynamic: BOOLEAN;
BEGIN
IF indexDesignator.type = NIL THEN
indexDesignator.SetType(newBaseType)
ELSE
ASSERT(indexDesignator.type.resolved IS SyntaxTree.MathArrayType);
mathArrayType := indexDesignator.type.resolved(SyntaxTree.MathArrayType);
makeDynamic :=
(newBaseType.resolved IS SyntaxTree.MathArrayType) &
(newBaseType.resolved(SyntaxTree.MathArrayType).form # SyntaxTree.Static);
WHILE (mathArrayType.arrayBase # NIL) & (mathArrayType.arrayBase IS SyntaxTree.MathArrayType) DO
IF makeDynamic THEN mathArrayType.SetForm(SyntaxTree.Open) END;
mathArrayType := mathArrayType.arrayBase(SyntaxTree.MathArrayType)
END;
IF makeDynamic THEN mathArrayType.SetForm(SyntaxTree.Open) END;
mathArrayType.SetArrayBase(newBaseType)
END
END SetIndexBaseType;
PROCEDURE AppendMathIndex(position: LONGINT; indexDesignator: SyntaxTree.IndexDesignator; indexListItem: SyntaxTree.Expression; sourceArray: SyntaxTree.MathArrayType);
VAR
targetArray: SyntaxTree.MathArrayType;
first, last, step: SyntaxTree.Expression;
firstValue, lastValue, stepValue, length: LONGINT;
rangeExpression: SyntaxTree.RangeExpression;
isStaticTargetArrayLength: BOOLEAN;
BEGIN
IF indexListItem.type = SyntaxTree.invalidType THEN
indexDesignator.parameters.AddExpression(indexListItem)
ELSIF indexListItem IS SyntaxTree.TensorRangeExpression THEN
indexDesignator.HasRange;
indexDesignator.HasTensorRange;
indexDesignator.parameters.AddExpression(indexListItem);
indexDesignator.SetType(SyntaxTree.NewMathArrayType(position, NIL, SyntaxTree.Tensor))
ELSIF indexListItem.type.resolved IS SyntaxTree.IntegerType THEN
IndexCheck(indexListItem, sourceArray.length);
indexListItem := NewConversion(InvalidPosition, indexListItem, system.sizeType, NIL);
indexDesignator.parameters.AddExpression(indexListItem)
ELSIF indexListItem.type.resolved IS SyntaxTree.RangeType THEN
indexDesignator.HasRange;
IF indexListItem IS SyntaxTree.RangeExpression THEN
rangeExpression := indexListItem(SyntaxTree.RangeExpression);
first := rangeExpression.first;
last := rangeExpression.last;
step := rangeExpression.step;
IF IsIntegerValue(first, firstValue) & (firstValue < 0) THEN
Error(indexListItem.position, Diagnostics.Invalid,"lower bound of array range too small")
END;
IF IsIntegerValue(last, lastValue) & (lastValue # MAX(LONGINT)) THEN
IF (sourceArray.length # NIL) & IsIntegerValue(sourceArray.length, length) & (lastValue > (length - 1)) THEN
Error(indexListItem.position, Diagnostics.Invalid,"upper bound of array range too large")
END
END;
IF IsIntegerValue(step, stepValue) & (stepValue < 1) THEN
Error(indexListItem.position, Diagnostics.Invalid,"invalid step size")
END;
rangeExpression.SetFirst(NewConversion(InvalidPosition, first, system.sizeType, NIL));
rangeExpression.SetLast(NewConversion(InvalidPosition, last, system.sizeType, NIL));
rangeExpression.SetStep(NewConversion(InvalidPosition, step, system.sizeType, NIL));
END;
IF indexDesignator.hasTensorRange THEN
ELSE
targetArray := SyntaxTree.NewMathArrayType(position, NIL, SyntaxTree.Open);
IF ~error THEN
END;
SetIndexBaseType(indexDesignator, targetArray)
END;
indexDesignator.parameters.AddExpression(indexListItem)
ELSE
Error(position, Diagnostics.Invalid,"invalid index list item");
END;
END AppendMathIndex;
PROCEDURE AppendIndex(position: LONGINT; index: SyntaxTree.IndexDesignator; expression: SyntaxTree.Expression; over: SyntaxTree.Type);
VAR parameters: SyntaxTree.ExpressionList;
BEGIN
parameters := index.parameters;
IF (expression.type = NIL) THEN
Error(position,Diagnostics.Invalid,"invalid index");
ELSIF IsIntegerType(expression.type.resolved) THEN
IF over IS SyntaxTree.ArrayType THEN
IndexCheck(expression,over(SyntaxTree.ArrayType).length);
ELSIF over IS SyntaxTree.StringType THEN
IndexCheck(expression,Global.NewIntegerValue(system, position, over(SyntaxTree.StringType).length));
END;
expression := NewConversion(InvalidPosition,expression,system.sizeType,NIL);
parameters.AddExpression(expression);
ELSE
Error(position,Diagnostics.Invalid,"invalid index");
END;
END AppendIndex;
PROCEDURE ConvertToMathArray(expression: SyntaxTree.Expression): SyntaxTree.Expression;
VAR
result: SyntaxTree.Expression;
indexList: SyntaxTree.ExpressionList;
mathArrayType: SyntaxTree.MathArrayType;
i: LONGINT;
BEGIN
IF expression.type = NIL THEN
result := SyntaxTree.invalidExpression
ELSIF expression.type.resolved IS SyntaxTree.MathArrayType THEN
result := expression
ELSIF IsArrayStructuredObjectType(expression.type) THEN
mathArrayType := MathArrayStructureOfType(expression.type);
result := NewIndexOperatorCall(InvalidPosition, expression, ListOfOpenRanges(mathArrayType.Dimensionality()), NIL)
ELSE
result := SyntaxTree.invalidExpression
END;
RETURN result
END ConvertToMathArray;
PROCEDURE ListOfOpenRanges(itemCount: LONGINT): SyntaxTree.ExpressionList;
VAR
result: SyntaxTree.ExpressionList;
i: LONGINT;
BEGIN
result := SyntaxTree.NewExpressionList();
FOR i := 1 TO itemCount DO
result.AddExpression(ResolveExpression(SyntaxTree.NewRangeExpression(InvalidPosition, NIL, NIL, NIL)))
END;
RETURN result
END ListOfOpenRanges;
PROCEDURE NewIndexOperatorCall*(position: LONGINT; left: SyntaxTree.Expression; indexList: SyntaxTree.ExpressionList; rhs: SyntaxTree.Expression): SyntaxTree.Designator;
VAR
operator: SyntaxTree.Operator;
expression: SyntaxTree.Expression;
actualParameters, tempList: SyntaxTree.ExpressionList;
tempMathArrayExpression: SyntaxTree.MathArrayExpression;
result, tempDesignator: SyntaxTree.Designator;
formalParameter: SyntaxTree.Parameter;
recordType: SyntaxTree.RecordType;
arrayAccessOperators: SyntaxTree.ArrayAccessOperators;
containsNonRange, usesPureRangeOperator, usesGeneralOperator, needsReshaping: BOOLEAN;
i, hashValue, indexListSize, indexListKind: LONGINT;
castReturnType: SyntaxTree.MathArrayType;
BEGIN
ASSERT(IsArrayStructuredObjectType(left.type));
ASSERT(left.type.resolved IS SyntaxTree.PointerType);
recordType := left.type.resolved(SyntaxTree.PointerType).pointerBase.resolved(SyntaxTree.RecordType);
indexListSize := indexList.Length();
indexListKind := 0;
containsNonRange := FALSE;
FOR i := 0 TO indexList.Length() - 1 DO
indexListKind := indexListKind * 2;
expression := indexList.GetExpression(i);
IF expression.type.resolved IS SyntaxTree.RangeType THEN
INC(indexListKind)
ELSE
containsNonRange := TRUE
END
END;
hashValue := IndexOperatorHash(indexListSize, indexListKind, recordType.arrayStructure.form = SyntaxTree.Tensor);
usesGeneralOperator := FALSE;
IF rhs # NIL THEN
IF hashValue = -1 THEN
operator := NIL
ELSE
operator := recordType.arrayAccessOperators.write[hashValue];
END;
IF operator = NIL THEN
usesPureRangeOperator := TRUE;
IF recordType.arrayStructure.form = SyntaxTree.Tensor THEN
operator := recordType.arrayAccessOperators.generalWrite;
usesGeneralOperator := TRUE
ELSE
hashValue := TwoToThePowerOf(indexListSize) - 1;
operator := recordType.arrayAccessOperators.write[hashValue];
END
END
ELSE
IF hashValue = -1 THEN
operator := NIL
ELSE
operator := recordType.arrayAccessOperators.read[hashValue];
END;
IF operator = NIL THEN
usesPureRangeOperator := TRUE;
IF recordType.arrayStructure.form = SyntaxTree.Tensor THEN
operator := recordType.arrayAccessOperators.generalRead;
usesGeneralOperator := TRUE
ELSE
hashValue := TwoToThePowerOf(indexListSize) - 1;
operator := recordType.arrayAccessOperators.read[hashValue];
END
END
END;
IF operator = NIL THEN
Error(position, Diagnostics.Invalid, "call of undeclared [] operator");
result := SyntaxTree.invalidDesignator;
ELSE
needsReshaping := containsNonRange & usesPureRangeOperator;
IF needsReshaping & ~arrayBaseImported THEN
ImportModule(Global.ArrayBaseName, InvalidPosition);
arrayBaseImported := TRUE
END;
actualParameters := SyntaxTree.NewExpressionList();
IF usesGeneralOperator THEN
tempMathArrayExpression := SyntaxTree.NewMathArrayExpression(InvalidPosition);
END;
FOR i := 0 TO indexListSize - 1 DO
expression := indexList.GetExpression(i);
IF (expression.type.resolved IS SyntaxTree.IntegerType) & needsReshaping THEN
tempList := SyntaxTree.NewExpressionList();
tempList.AddExpression(expression);
tempDesignator := SyntaxTree.NewIdentifierDesignator(InvalidPosition, Global.ArrayBaseName);
tempDesignator := SyntaxTree.NewSelectorDesignator(InvalidPosition, tempDesignator, SyntaxTree.NewIdentifier("RangeFromInteger"));
expression := ResolveExpression(SyntaxTree.NewParameterDesignator(InvalidPosition, tempDesignator, tempList));
END;
IF usesGeneralOperator THEN
tempMathArrayExpression.elements.AddExpression(expression);
ELSE
actualParameters.AddExpression(expression)
END
END;
IF usesGeneralOperator THEN
actualParameters.AddExpression(tempMathArrayExpression)
END;
IF rhs # NIL THEN
IF needsReshaping THEN
tempList := SyntaxTree.NewExpressionList();
IF rhs.type.resolved IS SyntaxTree.MathArrayType THEN
tempList.AddExpression(rhs);
ELSE
tempMathArrayExpression := SyntaxTree.NewMathArrayExpression(InvalidPosition);
tempMathArrayExpression.elements.AddExpression(rhs);
tempList.AddExpression(tempMathArrayExpression)
END;
tempMathArrayExpression := SyntaxTree.NewMathArrayExpression(InvalidPosition);
FOR i := 0 TO indexListSize - 1 DO
expression := indexList.GetExpression(i);
IF expression.type.resolved IS SyntaxTree.IntegerType THEN
tempMathArrayExpression.elements.AddExpression(SyntaxTree.NewBooleanValue(InvalidPosition, FALSE))
ELSE
tempMathArrayExpression.elements.AddExpression(SyntaxTree.NewBooleanValue(InvalidPosition, TRUE))
END
END;
tempList.AddExpression(tempMathArrayExpression);
tempDesignator := SyntaxTree.NewIdentifierDesignator(InvalidPosition, Global.ArrayBaseName);
tempDesignator := SyntaxTree.NewSelectorDesignator(InvalidPosition, tempDesignator, SyntaxTree.NewIdentifier("ExpandDimensions"));
expression := ResolveExpression(SyntaxTree.NewParameterDesignator(InvalidPosition, tempDesignator, tempList));
IF expression.type.resolved IS SyntaxTree.MathArrayType THEN
castReturnType := SyntaxTree.NewMathArrayType(Diagnostics.Invalid, expression.type.scope,SyntaxTree.Tensor);
castReturnType.SetArrayBase(ArrayBase(rhs.type.resolved,MAX(LONGINT)));
expression.SetType(castReturnType);
ELSE
Error(expression.position, Diagnostics.Invalid, "problem with resolving ArrayBase.ExpandDimensions");
END;
actualParameters.AddExpression(expression)
ELSE
actualParameters.AddExpression(rhs)
END
END;
ASSERT(left IS SyntaxTree.Designator);
expression := NewSymbolDesignator(InvalidPosition, NewDereferenceDesignator(InvalidPosition, left(SyntaxTree.Designator)), operator);
ASSERT(expression IS SyntaxTree.Designator);
result := NewProcedureCallDesignator(InvalidPosition, expression(SyntaxTree.Designator), actualParameters);
IF (rhs = NIL) & needsReshaping THEN
tempList := SyntaxTree.NewExpressionList();
FOR i := 0 TO indexList.Length() - 1 DO
expression := indexList.GetExpression(i);
IF expression.type.resolved IS SyntaxTree.IntegerType THEN
tempList.AddExpression(SyntaxTree.NewIntegerValue(InvalidPosition, 0))
ELSE
tempList.AddExpression(SyntaxTree.NewRangeExpression(InvalidPosition, NIL, NIL, NIL))
END
END;
result := ResolveDesignator(SyntaxTree.NewBracketDesignator(InvalidPosition, result, tempList))
END;
IF rhs = NIL THEN
result.SetAssignable(TRUE)
END;
result.SetRelatedAsot(left);
result.SetRelatedIndexList(indexList)
END;
RETURN result
END NewIndexOperatorCall;
PROCEDURE NewObjectOperatorCall*(position: LONGINT; left: SyntaxTree.Expression; parameters: SyntaxTree.ExpressionList; rhs: SyntaxTree.Expression): SyntaxTree.Designator;
VAR type: SyntaxTree.Type; expression: SyntaxTree.Expression; op: SyntaxTree.Operator; recordType: SyntaxTree.RecordType;
actualParameters: SyntaxTree.ExpressionList; i: LONGINT; result: SyntaxTree.Designator;
PROCEDURE FindOperator(recordType: SyntaxTree.RecordType; identifier: SyntaxTree.Identifier; actualParameters: SyntaxTree.ExpressionList): SyntaxTree.Operator;
VAR bestOperator: SyntaxTree.Operator; bestDistance: LONGINT; import: SyntaxTree.Import; numberParameters: LONGINT; procedureType: SyntaxTree.ProcedureType;
PROCEDURE FindInScope(scope: SyntaxTree.RecordScope; access: SET);
VAR operator: SyntaxTree.Operator; distance,i: LONGINT;
CONST trace = FALSE;
BEGIN
IF trace THEN
FOR i := 0 TO actualParameters.Length()-1 DO
Printout.Info("par", actualParameters.GetExpression(i));
END;
END;
operator := scope.firstOperator;
WHILE(operator # NIL) DO
IF (operator.name=identifier) & (operator.access * access # {}) THEN
procedureType := operator.type(SyntaxTree.ProcedureType);
distance := Distance(system, procedureType,actualParameters);
IF trace THEN Printout.Info("check op ",operator) END;
IF distance < bestDistance THEN
IF trace THEN Printout.Info("taken op",operator) END;
bestDistance := distance;
bestOperator := operator;
END;
END;
operator := operator.nextOperator;
END;
END FindInScope;
BEGIN
bestDistance := Infinity; bestOperator := NIL; numberParameters := actualParameters.Length();
identifier := SyntaxTree.NewIdentifier("[]");
WHILE (recordType # NIL) DO
FindInScope(recordType.recordScope,SyntaxTree.ReadOnly);
recordType := recordType.GetBaseRecord();
END;
RETURN bestOperator
END FindOperator;
BEGIN
type := left.type.resolved;
recordType := type(SyntaxTree.PointerType).pointerBase.resolved(SyntaxTree.RecordType);
actualParameters := SyntaxTree.NewExpressionList();
FOR i := 0 TO parameters.Length()-1 DO
expression := ResolveExpression(parameters.GetExpression(i));
actualParameters.AddExpression(expression);
END;
IF rhs # NIL THEN actualParameters.AddExpression(rhs) END;
op := FindOperator(recordType, SyntaxTree.NewIdentifier("[]"), actualParameters);
IF op # NIL THEN
expression := NewSymbolDesignator(position, NewDereferenceDesignator(InvalidPosition, left(SyntaxTree.Designator)) , op);
ASSERT(expression IS SyntaxTree.Designator);
result := NewProcedureCallDesignator(position, expression(SyntaxTree.Designator), actualParameters);
result.SetRelatedAsot(left);
result.SetRelatedIndexList(parameters);
IF (rhs = NIL) & (op.type(SyntaxTree.ProcedureType).returnType # NIL) THEN
actualParameters := SyntaxTree.NewExpressionList();
FOR i := 0 TO parameters.Length()-1 DO
expression := ResolveExpression(parameters.GetExpression(i));
actualParameters.AddExpression(expression);
END;
rhs := SyntaxTree.NewDesignator(); rhs.SetType(op.type(SyntaxTree.ProcedureType).returnType);
actualParameters.AddExpression(rhs);
op := FindOperator(recordType, SyntaxTree.NewIdentifier("[]"), actualParameters);
IF op = NIL THEN rhs := NIL END;
END;
IF rhs # NIL THEN result.SetAssignable(TRUE) END;
ELSE
Error(position,Diagnostics.Invalid,"undefined operator");
result := SyntaxTree.invalidDesignator
END;
RETURN result;
END NewObjectOperatorCall;
PROCEDURE VisitBracketDesignator(bracketDesignator: SyntaxTree.BracketDesignator);
VAR
leftBracketDesignator: SyntaxTree.BracketDesignator;
indexDesignator: SyntaxTree.IndexDesignator;
designator: SyntaxTree.Designator;
type: SyntaxTree.Type;
recordType: SyntaxTree.RecordType;
expression, rhs: SyntaxTree.Expression;
indexList: SyntaxTree.ExpressionList;
i: LONGINT;
hasError, done: BOOLEAN;
op: SyntaxTree.Operator;
actualParameters: SyntaxTree.ExpressionList;
result: SyntaxTree.Designator;
PROCEDURE FinalizeIndexDesignator;
BEGIN
IF indexDesignator # NIL THEN
IF IsTensor(type) THEN type := type(SyntaxTree.MathArrayType).arrayBase.resolved END;
SetIndexBaseType(indexDesignator, type);
indexDesignator.SetType(ResolveType(indexDesignator.type));
designator := indexDesignator;
type := designator.type.resolved;
indexDesignator := NIL;
ASSERT(SyntaxTree.Resolved IN type.state)
END
END FinalizeIndexDesignator;
BEGIN
IF Trace THEN D.Str("VisitBracketDesignator"); D.Ln; END;
IF bracketDesignator.left IS SyntaxTree.BracketDesignator THEN
leftBracketDesignator := bracketDesignator.left(SyntaxTree.BracketDesignator);
leftBracketDesignator.parameters.AddExpression(SyntaxTree.indexListSeparator);
FOR i := 0 TO bracketDesignator.parameters.Length() - 1 DO
leftBracketDesignator.parameters.AddExpression(bracketDesignator.parameters.GetExpression(i))
END;
leftBracketDesignator.SetRelatedRhs(bracketDesignator.relatedRhs);
resolvedExpression := ResolveExpression(leftBracketDesignator)
ELSE
ASSERT(~(bracketDesignator.left IS SyntaxTree.BracketDesignator));
designator := ResolveDesignator(bracketDesignator.left);
type := designator.type.resolved;
indexDesignator := NIL;
IF (type IS SyntaxTree.PointerType) & (type(SyntaxTree.PointerType).pointerBase.resolved IS SyntaxTree.RecordType) & ~IsArrayStructuredObjectType(type) THEN
resolvedExpression := NewObjectOperatorCall(bracketDesignator.position, designator, bracketDesignator.parameters,bracketDesignator.relatedRhs);
RETURN
END;
i := 0;
WHILE i <= bracketDesignator.parameters.Length() - 1 DO
expression := bracketDesignator.parameters.GetExpression(i);
expression := ResolveExpression(expression);
bracketDesignator.parameters.SetExpression(i, expression);
IF expression = SyntaxTree.indexListSeparator THEN
IF IsTensor(type) OR (indexDesignator # NIL) & (indexDesignator.hasRange) THEN FinalizeIndexDesignator END;
INC(i)
ELSE
IF (type IS SyntaxTree.PointerType) & ~IsArrayStructuredObjectType(type) THEN
IF (indexDesignator # NIL) & indexDesignator.hasRange THEN
Error(expression.position, Diagnostics.Invalid, "forbidden range valued indexer over pointer to array");
designator := SyntaxTree.invalidDesignator;
type := SyntaxTree.invalidType
ELSE
FinalizeIndexDesignator;
designator := NewDereferenceDesignator(bracketDesignator.position, designator);
type := designator.type.resolved
END
END;
IF (indexDesignator = NIL) & ((type IS SyntaxTree.ArrayType) OR (type IS SyntaxTree.MathArrayType) OR (type IS SyntaxTree.StringType)) THEN
indexDesignator := SyntaxTree.NewIndexDesignator(bracketDesignator.position, designator);
indexDesignator.SetAssignable(designator.assignable);
indexDesignator.SetType(NIL);
END;
IF type = SyntaxTree.invalidType THEN
INC(i)
ELSIF type IS SyntaxTree.ArrayType THEN
ASSERT(indexDesignator # NIL);
AppendIndex(expression.position, indexDesignator, expression, type(SyntaxTree.ArrayType));
type := type(SyntaxTree.ArrayType).arrayBase.resolved;
INC(i)
ELSIF type IS SyntaxTree.StringType THEN
ASSERT(indexDesignator # NIL);
AppendIndex(expression.position, indexDesignator, expression, type);
type := type(SyntaxTree.StringType).baseType.resolved;
INC(i)
ELSIF type IS SyntaxTree.MathArrayType THEN
ASSERT(indexDesignator # NIL);
AppendMathIndex(expression.position, indexDesignator, expression, type(SyntaxTree.MathArrayType));
IF type(SyntaxTree.MathArrayType).form # SyntaxTree.Tensor THEN type := type(SyntaxTree.MathArrayType).arrayBase.resolved END;
INC(i)
ELSIF IsArrayStructuredObjectType(type) THEN
FinalizeIndexDesignator;
ASSERT(type IS SyntaxTree.PointerType);
recordType := type(SyntaxTree.PointerType).pointerBase.resolved(SyntaxTree.RecordType);
indexList := SyntaxTree.NewExpressionList();
hasError := FALSE;
IF recordType.arrayStructure.form = SyntaxTree.Tensor THEN
done := FALSE;
WHILE ~done DO
IF i > bracketDesignator.parameters.Length() - 1 THEN
done := TRUE;
ELSE
expression := bracketDesignator.parameters.GetExpression(i);
IF expression = SyntaxTree.indexListSeparator THEN
done := TRUE;
ELSE
expression := ResolveExpression(expression);
IF expression IS SyntaxTree.TensorRangeExpression THEN
Error(expression.position, Diagnostics.Invalid, "tensor range expression not supported for tensor ASOTs");
hasError := TRUE
ELSIF ~(expression.type.resolved IS SyntaxTree.IntegerType) & ~(expression.type.resolved IS SyntaxTree.RangeType) THEN
Error(expression.position, Diagnostics.Invalid, "integer or range expected");
expression := SyntaxTree.invalidExpression;
hasError := TRUE
END;
indexList.AddExpression(expression)
END;
INC(i)
END
END
ELSE
WHILE indexList.Length() < recordType.arrayStructure.Dimensionality() DO
IF i <= bracketDesignator.parameters.Length() - 1 THEN
expression := bracketDesignator.parameters.GetExpression(i);
ELSE
expression := SyntaxTree.NewRangeExpression(InvalidPosition, NIL, NIL, NIL)
END;
IF expression # SyntaxTree.indexListSeparator THEN
expression := ResolveExpression(expression);
IF ~(expression.type.resolved IS SyntaxTree.IntegerType) & ~(expression.type.resolved IS SyntaxTree.RangeType) THEN
Error(expression.position, Diagnostics.Invalid, "integer or range expected");
expression := SyntaxTree.invalidExpression;
hasError := TRUE
END;
indexList.AddExpression(expression)
END;
INC(i)
END;
END;
IF hasError THEN
designator := SyntaxTree.invalidDesignator;
type := SyntaxTree.invalidType;
ELSE
IF (bracketDesignator.relatedRhs # NIL) & (i > bracketDesignator.parameters.Length() - 1) THEN
rhs := bracketDesignator.relatedRhs
ELSE
rhs := NIL
END;
designator := NewIndexOperatorCall(bracketDesignator.position, designator, indexList, rhs);
type := designator.type
END
ELSE
Error(expression.position, Diagnostics.Invalid,"indexing over non-array type");
designator := SyntaxTree.invalidDesignator;
type := SyntaxTree.invalidType;
INC(i)
END
END
END;
IF type # SyntaxTree.invalidType THEN FinalizeIndexDesignator END;
resolvedExpression := designator
END
END VisitBracketDesignator;
PROCEDURE ExpressionList(expressionList: SyntaxTree.ExpressionList): BOOLEAN;
VAR i: LONGINT; expression: SyntaxTree.Expression; result: BOOLEAN;
BEGIN
result := TRUE;
FOR i := 0 TO expressionList.Length()-1 DO
expression := ResolveExpression(expressionList.GetExpression(i));
IF expression = SyntaxTree.invalidExpression THEN result := FALSE END;
expressionList.SetExpression(i,expression);
END;
RETURN result
END ExpressionList;
PROCEDURE NewProcedureCallDesignator(position: LONGINT; left: SyntaxTree.Designator; actualParameters:SyntaxTree.ExpressionList): SyntaxTree.Designator;
VAR result: SyntaxTree.Designator;
numberFormalParameters, numberActualParameters: LONGINT;
formalType: SyntaxTree.ProcedureType;
formalParameter: SyntaxTree.Parameter;
actualParameter: SyntaxTree.Expression;
i: LONGINT;
hiddenPointerDesignator: SyntaxTree.Designator;
BEGIN
IF Trace THEN D.Str("ProcedureCallDesignator"); D.Ln; END;
result := SyntaxTree.invalidDesignator;
formalType := left.type.resolved(SyntaxTree.ProcedureType);
numberFormalParameters := formalType.numberParameters;
numberActualParameters := actualParameters.Length();
IF (currentIsRealtime) & ~(formalType.isRealtime) THEN
Error(position,Diagnostics.Invalid,"forbidden call of non-realtime procedure in realtime block");
END;
IF ~ExpressionList(actualParameters) THEN
result := SyntaxTree.invalidDesignator
ELSE
result := SyntaxTree.NewProcedureCallDesignator(position,left,actualParameters);
result.SetAssignable(FALSE);
result.SetType(left.type.resolved(SyntaxTree.ProcedureType).returnType);
IF numberActualParameters <= numberFormalParameters THEN
formalParameter := formalType.firstParameter;
FOR i := 0 TO numberActualParameters-1 DO
actualParameter := actualParameters.GetExpression(i);
IF (actualParameter = SyntaxTree.invalidExpression) THEN
ELSIF ~ParameterCompatible(formalParameter,actualParameter) THEN
ELSIF (currentIsRealtime) & ~actualParameter.type.resolved.isRealtime THEN
Error(position,Diagnostics.Invalid,"non-realtime actual parameter in context of realtime procedure");
ELSE
IF ~formalParameter.type.SameType(actualParameter.type.resolved) THEN
actualParameter := NewConversion(actualParameter.position,actualParameter,formalParameter.type,NIL);
END;
actualParameters.SetExpression(i,actualParameter);
END;
formalParameter := formalParameter.nextParameter;
END;
WHILE (formalParameter # NIL) DO
IF formalParameter.defaultValue # NIL THEN
actualParameters.AddExpression(formalParameter.defaultValue);
formalParameter := formalParameter.nextParameter
ELSE
Error(position,Diagnostics.Invalid,"less actual than formal parameters");
formalParameter := NIL;
END;
END;
ELSE
Error(position,Diagnostics.Invalid,"more actual than formal parameters")
END;
END;
RETURN result
END NewProcedureCallDesignator;
PROCEDURE VisitTypeGuardDesignator(x: SyntaxTree.TypeGuardDesignator);
BEGIN
resolvedExpression := x;
END VisitTypeGuardDesignator;
PROCEDURE VisitBuiltinCallDesignator(x: SyntaxTree.BuiltinCallDesignator);
BEGIN
resolvedExpression := x;
END VisitBuiltinCallDesignator;
PROCEDURE VisitProcedureCallDesignator(x: SyntaxTree.ProcedureCallDesignator);
BEGIN
resolvedExpression := x;
END VisitProcedureCallDesignator;
PROCEDURE CheckVariable(x: SyntaxTree.Expression): BOOLEAN;
VAR result: BOOLEAN;
BEGIN
result := TRUE;
IF x = SyntaxTree.invalidExpression THEN
result := FALSE;
ELSIF ~IsVariable(x) THEN
Error(x.position,Diagnostics.Invalid,"non variable expression");
IF VerboseErrorMessage THEN Printout.Info("non variable",x) END;
result := FALSE;
END;
RETURN result
END CheckVariable;
PROCEDURE CheckBasicType(x: SyntaxTree.Expression): BOOLEAN;
VAR result: BOOLEAN;
BEGIN
result := FALSE;
IF x = SyntaxTree.invalidExpression THEN
ELSIF ~IsBasicType(x.type) THEN
Error(x.position,Diagnostics.Invalid,"is no basic type");
result := FALSE
ELSE result := TRUE
END;
RETURN result
END CheckBasicType;
PROCEDURE CheckNumberType(x: SyntaxTree.Expression): BOOLEAN;
VAR result: BOOLEAN;
BEGIN
result := FALSE;
IF x = SyntaxTree.invalidExpression THEN
ELSIF ~(x.type.resolved IS SyntaxTree.NumberType) THEN
Error(x.position,Diagnostics.Invalid,"is non number type");
ELSE result := TRUE
END;
RETURN result
END CheckNumberType;
PROCEDURE CheckNonComplexNumberType(x: SyntaxTree.Expression): BOOLEAN;
VAR result: BOOLEAN;
BEGIN
result := FALSE;
IF x = SyntaxTree.invalidExpression THEN
ELSIF x.type.resolved IS SyntaxTree.ComplexType THEN
Error(x.position,Diagnostics.Invalid,"is complex type");
ELSIF ~(x.type.resolved IS SyntaxTree.NumberType) THEN
Error(x.position,Diagnostics.Invalid,"is non number type");
ELSE result := TRUE
END;
RETURN result
END CheckNonComplexNumberType;
PROCEDURE CheckIntegerType(x: SyntaxTree.Expression): BOOLEAN;
VAR result: BOOLEAN; type: SyntaxTree.Type;
BEGIN
result := FALSE; type := x.type.resolved;
IF x = SyntaxTree.invalidExpression THEN
ELSIF ~(type IS SyntaxTree.IntegerType) & ~(type IS SyntaxTree.ByteType) & ~(type IS SyntaxTree.AddressType) & ~(type IS SyntaxTree.SizeType) THEN
Error(x.position,Diagnostics.Invalid,"is no integer type");
ELSE result := TRUE
END;
RETURN result
END CheckIntegerType;
PROCEDURE CheckCharacterType(x: SyntaxTree.Expression): BOOLEAN;
VAR result: BOOLEAN;
BEGIN
result := FALSE;
IF x = SyntaxTree.invalidExpression THEN
ELSIF ~(x.type.resolved IS SyntaxTree.CharacterType) & ~(x.type.resolved IS SyntaxTree.ByteType) & ~IsCharacterType(x.type.resolved) THEN
Error(x.position,Diagnostics.Invalid,"is no character type");
ELSE result := TRUE
END;
RETURN result
END CheckCharacterType;
PROCEDURE CheckRealType(x: SyntaxTree.Expression): BOOLEAN;
VAR result: BOOLEAN;
BEGIN
result := FALSE;
IF x = SyntaxTree.invalidExpression THEN
ELSIF ~(x.type.resolved IS SyntaxTree.FloatType) THEN
Error(x.position,Diagnostics.Invalid,"is no float type");
ELSE result := TRUE
END;
RETURN result
END CheckRealType;
PROCEDURE CheckComplexType(x: SyntaxTree.Expression): BOOLEAN;
VAR result: BOOLEAN;
BEGIN
result := FALSE;
IF x = SyntaxTree.invalidExpression THEN
ELSIF ~(x.type.resolved IS SyntaxTree.ComplexType) THEN
Error(x.position,Diagnostics.Invalid,"is no complex type");
ELSE result := TRUE
END;
RETURN result
END CheckComplexType;
PROCEDURE CheckRangeType(x: SyntaxTree.Expression): BOOLEAN;
VAR result: BOOLEAN;
BEGIN
result := FALSE;
IF x = SyntaxTree.invalidExpression THEN
ELSIF ~(x.type.resolved IS SyntaxTree.RangeType) THEN
Error(x.position,Diagnostics.Invalid,"is no range type");
ELSE result := TRUE
END;
RETURN result
END CheckRangeType;
PROCEDURE CheckBooleanType(x: SyntaxTree.Expression): BOOLEAN;
VAR result: BOOLEAN;
BEGIN
result := FALSE;
IF x = SyntaxTree.invalidExpression THEN
ELSIF ~(x.type.resolved IS SyntaxTree.BooleanType) THEN
Error(x.position,Diagnostics.Invalid,"is no boolean type");
ELSE result := TRUE
END;
RETURN result
END CheckBooleanType;
PROCEDURE CheckSetType(x: SyntaxTree.Expression): BOOLEAN;
VAR result: BOOLEAN;
BEGIN
result := FALSE;
IF x = SyntaxTree.invalidExpression THEN
ELSIF ~(x.type.resolved IS SyntaxTree.SetType) THEN
Error(x.position,Diagnostics.Invalid,"is no set type");
ELSE result := TRUE
END;
RETURN result
END CheckSetType;
PROCEDURE CheckStringType(x: SyntaxTree.Expression): BOOLEAN;
VAR result: BOOLEAN;
BEGIN
result := FALSE;
IF x = SyntaxTree.invalidExpression THEN
ELSIF ~IsStringType(x.type.resolved) THEN
Error(x.position,Diagnostics.Invalid,"is no string type");
ELSE result := TRUE
END;
RETURN result
END CheckStringType;
PROCEDURE CheckTypeDeclarationType(x: SyntaxTree.Expression): BOOLEAN;
VAR result: BOOLEAN;
BEGIN
result := FALSE;
IF x = SyntaxTree.invalidExpression THEN
ELSIF (x.type.resolved # SyntaxTree.typeDeclarationType) THEN
Error(x.position,Diagnostics.Invalid,"is not a type declaration");
ELSE result := TRUE
END;
RETURN result
END CheckTypeDeclarationType;
PROCEDURE CheckIntegerValue(x: SyntaxTree.Expression; VAR value: LONGINT): BOOLEAN;
VAR result: BOOLEAN;
BEGIN
result := FALSE;
IF x = SyntaxTree.invalidExpression THEN
ELSIF (x.resolved # NIL) & (x.resolved IS SyntaxTree.IntegerValue) THEN
result := TRUE;
value := x.resolved(SyntaxTree.IntegerValue).value;
ELSE
Error(x.position,Diagnostics.Invalid,"expression is not an integer constant");
END;
RETURN result;
END CheckIntegerValue;
PROCEDURE CheckEnumerationValue(x: SyntaxTree.Expression; VAR value: LONGINT): BOOLEAN;
VAR result: BOOLEAN;
BEGIN
result := FALSE;
IF x = SyntaxTree.invalidExpression THEN
ELSIF (x.resolved # NIL) & (x.resolved IS SyntaxTree.EnumerationValue) THEN
result := TRUE;
value := x.resolved(SyntaxTree.EnumerationValue).value;
ELSE
Error(x.position,Diagnostics.Invalid,"expression is not an integer constant");
END;
RETURN result;
END CheckEnumerationValue;
PROCEDURE CheckCharacterValue(x: SyntaxTree.Expression; VAR value: CHAR): BOOLEAN;
VAR result: BOOLEAN;
BEGIN
result := FALSE;
IF x = SyntaxTree.invalidExpression THEN
ELSIF (x.resolved # NIL) & (x.resolved IS SyntaxTree.CharacterValue) THEN
result := TRUE;
value := x.resolved(SyntaxTree.CharacterValue).value;
ELSIF (x.resolved # NIL) & (x.resolved IS SyntaxTree.StringValue) & (x.resolved(SyntaxTree.StringValue).length =2) THEN
result := TRUE;
value := x.resolved(SyntaxTree.StringValue).value[0];
ELSE
Error(x.position,Diagnostics.Invalid,"expression is not a character constant");
END;
RETURN result;
END CheckCharacterValue;
PROCEDURE CheckStringValue(x: SyntaxTree.Expression; VAR value: SyntaxTree.String): BOOLEAN;
VAR result: BOOLEAN;
BEGIN
result := FALSE;
IF x = SyntaxTree.invalidExpression THEN
ELSIF (x.resolved # NIL) & (x.resolved IS SyntaxTree.StringValue) THEN
result := TRUE;
value := x.resolved(SyntaxTree.StringValue).value;
ELSE
Error(x.position,Diagnostics.Invalid,"expression is not a string constant");
END;
RETURN result
END CheckStringValue;
PROCEDURE CheckPositiveIntegerValue(x: SyntaxTree.Expression; VAR value: LONGINT; includeZero: BOOLEAN): BOOLEAN;
VAR result: BOOLEAN;
BEGIN
result := FALSE;
IF x = SyntaxTree.invalidExpression THEN
ELSIF (x.resolved # NIL) & (x.resolved IS SyntaxTree.IntegerValue) THEN
value := x.resolved(SyntaxTree.IntegerValue).value;
IF (value > 0) OR includeZero & (value = 0) THEN
result := TRUE;
ELSE
Error(x.position,Diagnostics.Invalid,"integer is not positive");
END
ELSE
Error(x.position,Diagnostics.Invalid,"expression is not an integer constant");
END;
RETURN result;
END CheckPositiveIntegerValue;
PROCEDURE CheckPortType(x: SyntaxTree.Expression; VAR portType: SyntaxTree.PortType): BOOLEAN;
VAR type: SyntaxTree.Type; result: BOOLEAN;
BEGIN
result := FALSE;
IF x = SyntaxTree.invalidExpression THEN
ELSE
type := x.type.resolved;
IF (type # NIL) & (type IS SyntaxTree.PortType) THEN
portType := type(SyntaxTree.PortType);
result := TRUE
ELSE
Error(x.position,Diagnostics.Invalid,"no port type");
END;
END;
RETURN result
END CheckPortType;
PROCEDURE IsPortType(x: SyntaxTree.Expression; VAR portType: SyntaxTree.PortType): BOOLEAN;
VAR type: SyntaxTree.Type; result: BOOLEAN;
BEGIN
result := FALSE;
IF x = SyntaxTree.invalidExpression THEN
ELSE
type := x.type.resolved;
IF (type # NIL) & (type IS SyntaxTree.PortType) THEN
portType := type(SyntaxTree.PortType);
result := TRUE
END;
END;
RETURN result
END IsPortType;
PROCEDURE NewBuiltinCallDesignator(position: LONGINT; builtin: SyntaxTree.Builtin; actualParameters:SyntaxTree.ExpressionList; left: SyntaxTree.Designator): SyntaxTree.Expression;
VAR
numberActualParameters,numberFormalParameters: LONGINT;
formalParameter: SyntaxTree.Parameter;
actualParameter: SyntaxTree.Expression;
procedureType: SyntaxTree.ProcedureType;
parameter0, parameter1, parameter2, result, expression: SyntaxTree.Expression;
designator : SyntaxTree.Designator;
inPort, outPort: SyntaxTree.PortType;
constructor: SyntaxTree.Procedure;
type0,type1,type2: SyntaxTree.Type;
type,base,parameterType: SyntaxTree.Type;
arrayType: SyntaxTree.ArrayType;
parameter: SyntaxTree.Parameter;
procedure: SyntaxTree.Procedure;
i,i0,i1: LONGINT;
r,r0,r1,im: LONGREAL;
c: CHAR;
id: LONGINT;
b: BOOLEAN;
name: SyntaxTree.String;
mathArrayType: SyntaxTree.MathArrayType;
device: ActiveCells.Device;
customBuiltin: SyntaxTree.CustomBuiltin;
PROCEDURE CheckArity(from,to: LONGINT): BOOLEAN;
VAR resultB: BOOLEAN;
BEGIN
IF numberActualParameters < from THEN
Error(position,Diagnostics.Invalid,"less actual than formal parameters");
result := SyntaxTree.invalidExpression;
resultB := FALSE;
ELSIF numberActualParameters > to THEN
Error(position,Diagnostics.Invalid,"more actual than formal parameters");
result := SyntaxTree.invalidExpression;
resultB := FALSE;
ELSE
resultB := TRUE;
END;
RETURN resultB
END CheckArity;
BEGIN
type := NIL; result := NIL;
type0 := NIL; type1 := NIL; type2 := NIL;
numberActualParameters := actualParameters.Length();
IF numberActualParameters>0 THEN
parameter0 := actualParameters.GetExpression(0);
IF parameter0.type # NIL THEN type0 := parameter0.type.resolved<