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 ELSE
Error(parameter0.position,Diagnostics.Invalid,"forbidden type-less argument");
result := SyntaxTree.invalidExpression
END
END;
IF numberActualParameters >1 THEN
parameter1 := actualParameters.GetExpression(1);
IF parameter1.type # NIL THEN type1 := parameter1.type.resolved
ELSE
Error(parameter1.position,Diagnostics.Invalid,"forbidden type-less argument");
result := SyntaxTree.invalidExpression
END
END;
IF numberActualParameters >2 THEN
parameter2 := actualParameters.GetExpression(2);
IF parameter2.type # NIL THEN type2 := parameter2.type.resolved
ELSE
Error(parameter2.position,Diagnostics.Invalid,"forbidden type-less argument");
result := SyntaxTree.invalidExpression
END
END;
id := builtin.id;
IF system.operatorDefined[id] THEN
result := NewOperatorCall(position,builtin.id,parameter0,parameter1,NIL);
END;
IF result = SyntaxTree.invalidExpression THEN
ELSIF result # NIL THEN type := result.type
ELSE
result := SyntaxTree.NewBuiltinCallDesignator(position,id,left,actualParameters);
result(SyntaxTree.Designator).SetLeft(left);
IF (id = Global.Assert) & CheckArity(1,2) THEN
IF CheckBooleanType(parameter0) THEN
IF IsBooleanValue(parameter0,b) & ~b & ~(currentIsUnreachable) THEN
Error(position,Diagnostics.Invalid,"assert failed");
END;
IF (numberActualParameters > 1) & CheckIntegerValue(parameter1,i1) THEN
END;
END;
ELSIF (id = Global.Copy) & CheckArity(2,2) THEN
IF~IsStringType(type0) THEN
Error(parameter0.position,Diagnostics.Invalid,"no string type");
END;
IF ~IsStringType(type1) THEN
Error(parameter1.position,Diagnostics.Invalid,"no string type");
ELSIF CheckVariable(parameter1) THEN
IF (type0 IS SyntaxTree.StringType) THEN
arrayType := type1(SyntaxTree.ArrayType);
IF arrayType.form = SyntaxTree.Static THEN
IF arrayType.staticLength < type0(SyntaxTree.StringType).length THEN
Error(position,Diagnostics.Invalid,"destination length smaller than source length")
END;
END;
END;
END;
ELSIF ((id = Global.Dec) OR (id = Global.Inc)) & CheckArity(1,2) THEN
IF numberActualParameters = 1 THEN
parameter1 :=Global.NewIntegerValue(system,position,1);
actualParameters.AddExpression(parameter1);
END;
IF CheckVariable(parameter0) & CheckIntegerType(parameter0) & CheckIntegerType(parameter1) THEN
IF ~CompatibleTo(system,parameter1.type,parameter0.type) THEN
Error(position,Diagnostics.Invalid,"incompatible increment");
ELSE
parameter1 := NewConversion(0,parameter1,parameter0.type,NIL);
actualParameters.SetExpression(1,parameter1);
END;
END;
ELSIF ((id = Global.Excl) OR (id = Global.Incl)) & CheckArity(2,2) THEN
IF CheckVariable(parameter0) & CheckSetType(parameter0) & CheckIntegerType(parameter1) THEN
IF IsIntegerValue(parameter1,i0) THEN
IF (i0 < 0) OR (i0>= system.setType.sizeInBits) THEN
Error(position,Diagnostics.Invalid,"parameter out of SET range")
END;
END;
parameter1 := NewConversion(0,parameter1,system.longintType,NIL);
actualParameters.SetExpression(1,parameter1);
END;
ELSIF ((id = Global.Halt) OR (id = Global.systemHalt)) & CheckArity(1,1) THEN
IF CheckPositiveIntegerValue(parameter0,i0,FALSE) THEN
END;
ELSIF (id = Global.New) & CheckArity(1,Infinity) THEN
IF currentIsRealtime THEN
Error(position,Diagnostics.Invalid,"forbidden new in realtime block");
END;
IF CheckVariable(parameter0) THEN
IF type0 IS SyntaxTree.PointerType THEN
base := type0(SyntaxTree.PointerType).pointerBase.resolved;
IF base IS SyntaxTree.ArrayType THEN
arrayType := base(SyntaxTree.ArrayType);
IF arrayType.form = SyntaxTree.Static THEN
i := 1
ELSIF arrayType.form = SyntaxTree.Open THEN
i := Dimension(arrayType,{SyntaxTree.Open})+1;
ELSE HALT(100)
END;
IF CheckArity(i,i) & (numberActualParameters>1) THEN
i := 1;
REPEAT
actualParameter := actualParameters.GetExpression(i);
IF CheckIntegerType(actualParameter) THEN
actualParameter := NewConversion(0,actualParameter,system.longintType,NIL);
actualParameters.SetExpression(i,actualParameter);
END;
INC(i);
UNTIL ~CheckIntegerType(actualParameter) OR (actualParameter.resolved # NIL) & ~CheckPositiveIntegerValue(actualParameter,i0,TRUE) OR (i=numberActualParameters);
END;
ELSE
ASSERT(base IS SyntaxTree.RecordType);
constructor := GetConstructor(base(SyntaxTree.RecordType));
IF constructor = NIL THEN
IF CheckArity(1,1) THEN END;
ELSIF (constructor.scope.ownerModule # currentScope.ownerModule) & ~(SyntaxTree.PublicRead IN constructor.access) THEN
Error(position,Diagnostics.Invalid,"new on object with hidden constructor");
ELSE
procedureType := constructor.type(SyntaxTree.ProcedureType);
numberFormalParameters := procedureType.numberParameters;
DEC(numberActualParameters);
IF numberActualParameters <= numberFormalParameters THEN
formalParameter := procedureType.firstParameter;
FOR i := 1 TO numberActualParameters DO
actualParameter := actualParameters.GetExpression(i);
IF (actualParameter = SyntaxTree.invalidExpression) THEN
ELSIF ~ParameterCompatible(formalParameter,actualParameter) THEN
ELSE
IF formalParameter.type.resolved # 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;
END;
ELSIF type0 IS SyntaxTree.MathArrayType THEN
mathArrayType := type0(SyntaxTree.MathArrayType);
IF mathArrayType.form = SyntaxTree.Static THEN
Error(position,Diagnostics.Invalid,"new on static array");
ELSE
IF mathArrayType.form = SyntaxTree.Tensor THEN
i0 := 2; i1 := Infinity;
ELSIF mathArrayType.form = SyntaxTree.Open THEN
i0 := Dimension(mathArrayType,{SyntaxTree.Open})+1;
i1 := i0;
ELSE HALT(100);
END;
IF type1 IS SyntaxTree.MathArrayType THEN
base := ArrayBase(type0,MAX(LONGINT));
parameterType := SyntaxTree.NewMathArrayType(Diagnostics.Invalid,currentScope,SyntaxTree.Tensor);
parameterType(SyntaxTree.MathArrayType).SetArrayBase(base);
IF ~CompatibleTo(system,type0,parameterType) THEN
Error(parameter0.position,Diagnostics.Invalid,"incompatible parameter in new");
result := SyntaxTree.invalidExpression;
ELSE
parameter0 := NewConversion(Diagnostics.Invalid,parameter0,parameterType,NIL); actualParameters.SetExpression(0,parameter0);
END;
parameterType := SyntaxTree.NewMathArrayType(Diagnostics.Invalid,currentScope,SyntaxTree.Open);
parameterType(SyntaxTree.MathArrayType).SetArrayBase(system.longintType);
IF ~CompatibleTo(system,type1,parameterType) THEN
Error(parameter1.position,Diagnostics.Invalid,"parameter incompatible to math array of longint");
result := SyntaxTree.invalidExpression;
ELSE
parameter1 := NewConversion(Diagnostics.Invalid,parameter1,parameterType,NIL); actualParameters.SetExpression(1,parameter1);
END;
ELSE
IF CheckArity(i0,i1) & (numberActualParameters >1) THEN
i := 1;
REPEAT
actualParameter := actualParameters.GetExpression(i);
IF CheckIntegerType(actualParameter) THEN
actualParameter := NewConversion(0,actualParameter,system.sizeType,NIL);
actualParameters.SetExpression(i,actualParameter);
END;
INC(i);
UNTIL ~CheckIntegerType(actualParameter) OR (actualParameter.resolved # NIL) & ~CheckPositiveIntegerValue(actualParameter,i0,TRUE) OR (i=numberActualParameters);
END;
END;
END;
ELSIF type0 IS SyntaxTree.CellType THEN
IF ~(currentIsCellNet) THEN
Error(position,Diagnostics.Invalid,"cell allocation outside activeCells ");
ELSE
constructor := type0(SyntaxTree.CellType).cellScope.constructor;
IF (constructor = NIL) & CheckArity(1,1) THEN
ELSE
procedureType := constructor.type(SyntaxTree.ProcedureType);
numberFormalParameters := procedureType.numberParameters;
DEC(numberActualParameters);
IF numberActualParameters <= numberFormalParameters THEN
formalParameter := procedureType.firstParameter;
FOR i := 1 TO numberActualParameters DO
actualParameter := actualParameters.GetExpression(i);
IF (actualParameter = SyntaxTree.invalidExpression) THEN
ELSIF ~ParameterCompatible(formalParameter,actualParameter) THEN
ELSE
IF formalParameter.type.resolved # 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;
END;
activeCellsStatement := TRUE;
ELSE
Error(position,Diagnostics.Invalid,"cannot be allocated");
END;
END;
ELSIF (id = Global.Dispose) & CheckArity(1,1) THEN
IF ~IsPointerType(parameter0.type) THEN
Error(parameter0.position,Diagnostics.Invalid,"is not a pointer")
ELSIF CheckVariable(parameter0) THEN
END
ELSIF (id = Global.GetProcedure) & CheckArity(3,3) THEN
IF CheckStringType(parameter0) & CheckStringType(parameter1) THEN
IF CheckVariable(parameter2) THEN
IF ~GetProcedureAllowed(parameter2.type) THEN
Error(parameter2.position,Diagnostics.Invalid,"GETPROCEDURE not allowed on this type");
END;
END;
END;
ELSIF (id = Global.Abs) & CheckArity(1,1) THEN
IF CheckNonComplexNumberType(parameter0) THEN
type := type0;
IF IsIntegerValue(parameter0,i0) THEN
result.SetResolved(SyntaxTree.NewIntegerValue(position,ABS(i0)));
type := Global.GetIntegerType(system,ABS(i0));
ELSIF IsRealValue(parameter0,r) THEN
result.SetResolved(SyntaxTree.NewRealValue(position,ABS(r)));
END;
ELSE
type := SyntaxTree.invalidType;
END;
ELSIF (id = Global.Ash) & CheckArity(2,2) THEN
type := type0;
IF CheckIntegerType(parameter0) & CheckIntegerType(parameter1) THEN
ConvertOperands(parameter0,parameter1);
type := parameter0.type;
IF IsIntegerValue(parameter0,i0) THEN
IF IsIntegerValue(parameter1,i1) THEN
i0 := ASH(i0,i1);
result.SetResolved(SyntaxTree.NewIntegerValue(position,i0));
result := ResolveExpression(result);
type := Global.GetIntegerType(system,i0);
END;
END;
IF type.resolved.sizeInBits < 32 THEN
type := system.longintType;
END;
parameter1 := NewConversion(parameter1.position,parameter1,system.longintType,NIL);
parameter0 := NewConversion(parameter0.position,parameter0,type,NIL);
actualParameters.SetExpression(0,parameter0);
actualParameters.SetExpression(1,parameter1);
END;
ELSIF (id = Global.Cap) & CheckArity(1,1) THEN
type := system.characterType;
IF CheckCharacterType (parameter0) THEN
parameter0 := NewConversion(parameter0.position,parameter0,type,NIL);
actualParameters.SetExpression(0,parameter0);
IF IsCharacterValue(parameter0,c) THEN
IF (c <= "z") & (c >= "a") THEN
result.SetResolved(SyntaxTree.NewCharacterValue(position,CAP(c)))
ELSE
result.SetResolved(SyntaxTree.NewCharacterValue(position,c))
END;
END;
END;
ELSIF (id = Global.Chr) & CheckArity(1,1) THEN
type := system.characterType;
IF CheckIntegerType(parameter0) THEN
IF IsIntegerValue(parameter0,i0) THEN
result.SetResolved(SyntaxTree.NewCharacterValue(position,CHR(i0)));
result := ResolveExpression(result);
ELSE
END;
END
ELSIF (id = Global.Entier) & CheckArity(1,1) THEN
type := system.longintType;
IF CheckRealType(parameter0) THEN
IF IsRealValue(parameter0,r) THEN
result.SetResolved(SyntaxTree.NewIntegerValue(position,ENTIER(r)));
type := Global.GetIntegerType(system,ENTIER(r));
END
END;
ELSIF (id = Global.EntierH) & CheckArity(1,1) THEN
type := system.hugeintType;
IF CheckRealType(parameter0) THEN
IF IsRealValue(parameter0,r) THEN
result.SetResolved(SyntaxTree.NewIntegerValue(position,ENTIERH(r)));
END
END;
ELSIF (id = Global.Len) & CheckArity(1,2) THEN
type := system.longintType;
base := type0;
IF (base IS SyntaxTree.PointerType) & (parameter0 IS SyntaxTree.Designator) THEN
parameter0 := NewDereferenceDesignator(position,parameter0(SyntaxTree.Designator));
actualParameters.SetExpression(0,parameter0);
type0 := parameter0.type.resolved;
base := type0;
END;
IF (numberActualParameters=1) OR (numberActualParameters =2) & CheckIntegerType(parameter1) THEN
IF ~(numberActualParameters=2) OR ~IsIntegerValue(parameter1,i1) THEN i1 := 0 END;
IF i1 < 0 THEN
Error(position,Diagnostics.Invalid,"invalid dimension");
base := SyntaxTree.invalidType;
ELSE
base := ArrayBase(base,i1);
IF (base # NIL) & Indexable(base) THEN
ELSE
Error(position,Diagnostics.Invalid,"len on no array");
IF VerboseErrorMessage THEN
Printout.Info("base",base);
END;
base := SyntaxTree.invalidType;
END;
END;
IF numberActualParameters=2 THEN
parameter1 := NewConversion(parameter1.position,parameter1,system.longintType,NIL);
actualParameters.SetExpression(1,parameter1);
ELSIF base IS SyntaxTree.MathArrayType THEN
Error(position,Diagnostics.Invalid,"missing dimension specification");
END;
IF (numberActualParameters=1) OR (numberActualParameters =2) & IsIntegerValue(parameter1,i1) THEN
IF base IS SyntaxTree.ArrayType THEN
arrayType := base(SyntaxTree.ArrayType);
IF (arrayType.length # NIL) & (arrayType.length.resolved # NIL) & IsIntegerValue(arrayType.length,i) THEN
result := Global.NewIntegerValue(system,position,i);
type := result.type;
ASSERT(type # NIL);
END;
ELSIF base IS SyntaxTree.MathArrayType THEN
mathArrayType := base(SyntaxTree.MathArrayType);
IF (mathArrayType.length # NIL) & (mathArrayType.length.resolved # NIL) & IsIntegerValue(mathArrayType.length,i) THEN
result := Global.NewIntegerValue(system,position,i);
type := result.type;
ASSERT(type # NIL);
END;
END;
END;
ELSE
type := system.longintType;
END;
ELSIF (id = Global.First) & CheckArity(1,1) THEN
type := system.longintType;
IF CheckRangeType(parameter0) THEN END;
result.SetAssignable(parameter0.assignable)
ELSIF (id = Global.Last) & CheckArity(1,1) THEN
type := system.longintType;
IF CheckRangeType(parameter0) THEN END;
result.SetAssignable(parameter0.assignable)
ELSIF (id = Global.Step) & CheckArity(1,1) THEN
type := system.longintType;
IF CheckRangeType(parameter0) THEN END;
result.SetAssignable(parameter0.assignable)
ELSIF (id = Global.Re) & CheckArity(1,1) THEN
IF CheckNumberType(parameter0) THEN
IF parameter0.type.resolved IS SyntaxTree.ComplexType THEN
type := parameter0.type.resolved(SyntaxTree.ComplexType).componentType;
IF IsComplexValue(parameter0, r, im) THEN result.SetResolved(SyntaxTree.NewRealValue(parameter0.position, r)) END
ELSIF parameter0.type.resolved IS SyntaxTree.FloatType THEN
type := parameter0.type
ELSE
type := system.realType
END
END;
result.SetAssignable(parameter0.assignable)
ELSIF (id = Global.Im) & CheckArity(1,1) THEN
IF CheckNumberType(parameter0) THEN
IF parameter0.type.resolved IS SyntaxTree.ComplexType THEN
type := parameter0.type.resolved(SyntaxTree.ComplexType).componentType;
IF IsComplexValue(parameter0, r, im) THEN result.SetResolved(SyntaxTree.NewRealValue(parameter0.position, im)) END
ELSE
type := system.realType;
result.SetResolved(SyntaxTree.NewRealValue(parameter0.position, 0))
END
END;
result.SetAssignable(parameter0.assignable)
ELSIF (id = Global.Max) & CheckArity(1,2) THEN
IF numberActualParameters = 1 THEN
IF parameter0.type = SyntaxTree.typeDeclarationType THEN
type := parameter0(SyntaxTree.SymbolDesignator).symbol(SyntaxTree.TypeDeclaration).declaredType.resolved;
IF type IS SyntaxTree.CharacterType THEN result.SetResolved(SyntaxTree.NewCharacterValue(position,MAX(CHAR)));
ELSIF type IS SyntaxTree.IntegerType THEN result.SetResolved(SyntaxTree.NewIntegerValue(position,Global.MaxInteger(system,type(SyntaxTree.IntegerType))));
ELSIF type IS SyntaxTree.FloatType THEN result.SetResolved(SyntaxTree.NewRealValue(position,Global.MaxFloat(system,type(SyntaxTree.FloatType))));
ELSIF type IS SyntaxTree.SetType THEN result.SetResolved(SyntaxTree.NewIntegerValue(position,system.SizeOf(type)-1)); type := system.shortintType;
ELSIF type IS SyntaxTree.SizeType THEN result.SetResolved(SyntaxTree.NewIntegerValue(position,Global.MaxInteger(system,type(SyntaxTree.BasicType))));
ELSE Error(Diagnostics.Invalid,parameter0.position,"builtin function not applicable to this type");
END;
ELSE
Error(parameter0.position,Diagnostics.Invalid,"is not a type symbol");
END
ELSIF CheckNonComplexNumberType(parameter0) & CheckNonComplexNumberType(parameter1) THEN
ConvertOperands(parameter0,parameter1);
actualParameters.SetExpression(0,parameter0);
actualParameters.SetExpression(1,parameter1);
IF IsRealValue(parameter0,r0) & IsRealValue(parameter1,r1) THEN
IF r0 > r1 THEN result.SetResolved(parameter0(SyntaxTree.Value))
ELSE result.SetResolved(parameter0(SyntaxTree.Value))
END;
ELSIF IsIntegerValue(parameter0,i0) & IsIntegerValue(parameter1,i1) THEN
IF i0 > i1 THEN result.SetResolved(parameter0(SyntaxTree.Value))
ELSE result.SetResolved(parameter1(SyntaxTree.Value))
END;
END;
type := parameter0.type;
ELSE type := SyntaxTree.invalidType;
END;
ELSIF (id = Global.Min) & CheckArity(1,2) THEN
IF numberActualParameters = 1 THEN
IF parameter0.type = SyntaxTree.typeDeclarationType THEN
type := parameter0(SyntaxTree.SymbolDesignator).symbol(SyntaxTree.TypeDeclaration).declaredType.resolved;
IF type IS SyntaxTree.CharacterType THEN result.SetResolved(SyntaxTree.NewCharacterValue(position,MIN(CHAR)));
ELSIF type IS SyntaxTree.IntegerType THEN result.SetResolved(SyntaxTree.NewIntegerValue(position,Global.MinInteger(system,type(SyntaxTree.IntegerType))));
ELSIF type IS SyntaxTree.FloatType THEN result.SetResolved(SyntaxTree.NewRealValue(position,Global.MinFloat(system,type(SyntaxTree.FloatType))));
ELSIF type IS SyntaxTree.SetType THEN result.SetResolved(SyntaxTree.NewIntegerValue(position,0)); type := system.shortintType;
ELSIF type IS SyntaxTree.SizeType THEN result.SetResolved(SyntaxTree.NewIntegerValue(position, Global.MinInteger(system,type(SyntaxTree.BasicType))));
ELSE Error(parameter0.position,Diagnostics.Invalid,"builtin function not applicable to this type");
END;
ELSE
Error(parameter0.position,Diagnostics.Invalid,"is not a type symbol");
END
ELSIF CheckNonComplexNumberType(parameter0) & CheckNonComplexNumberType(parameter1) THEN
ConvertOperands(parameter0,parameter1);
actualParameters.SetExpression(0,parameter0);
actualParameters.SetExpression(1,parameter1);
IF IsRealValue(parameter0,r0) & IsRealValue(parameter1,r1) THEN
IF r0 < r1 THEN result.SetResolved(parameter0.resolved)
ELSE result.SetResolved(parameter1.resolved)
END;
ELSIF IsIntegerValue(parameter0,i0) & IsIntegerValue(parameter1,i1) THEN
IF i0 < i1 THEN result.SetResolved(parameter0.resolved)
ELSE result.SetResolved(parameter1.resolved)
END;
END;
type := parameter0.type;
ELSE type := SyntaxTree.invalidType;
END;
ELSIF (id = Global.Odd) & CheckArity(1,1) THEN
type := system.booleanType;
IF CheckIntegerType(parameter0) THEN
IF IsIntegerValue(parameter0,i0) THEN
result.SetResolved(SyntaxTree.NewBooleanValue(position,ODD(i0)));
type := system.booleanType;
END;
END;
ELSIF (id = Global.Ord) & CheckArity(1,1) THEN
type := system.integerType;
IF CompatibleTo(system, parameter0.type, system.characterType) THEN
parameter0 := NewConversion(parameter0.position, parameter0, system.characterType,NIL);
actualParameters.SetExpression(0,parameter0);
IF IsCharacterValue(parameter0,c)THEN
result.SetResolved(Global.NewIntegerValue(system,position,ORD(c)));
type := Global.GetIntegerType(system,ORD(c));
END;
ELSE Error(parameter0.position, Diagnostics.Invalid, "incompatible parameter");
END;
ELSIF (id = Global.Short) & CheckArity(1,1) THEN
type := type0;
IF IsIntegerType(type) THEN
IF type.sizeInBits = 8 THEN Error(parameter0.position,Diagnostics.Invalid,"short not applicable")
ELSE
CASE type.sizeInBits OF
16: type := Global.Integer8
|32: type := Global.Integer16
|64: type := Global.Integer32
END;
END;
ELSIF type IS SyntaxTree.FloatType THEN
IF type.sizeInBits = 32 THEN Error(parameter0.position,Diagnostics.Invalid,"short not applicable")
ELSIF type.sizeInBits = 64 THEN type := Global.Float32
END;
ELSIF type IS SyntaxTree.ComplexType THEN
IF type.sizeInBits = 64 THEN Error(parameter0.position,Diagnostics.Invalid,"short not applicable")
ELSIF type.sizeInBits = 128 THEN type := Global.Complex64
END;
ELSE
Error(parameter0.position,Diagnostics.Invalid,"short not applicable")
END;
IF (parameter0.resolved # NIL) THEN
parameter0 := ConvertValue(parameter0.position,parameter0.resolved,type);
IF parameter0 IS SyntaxTree.Value THEN
result.SetResolved(parameter0(SyntaxTree.Value));
END;
END;
ELSIF (id = Global.Long) & CheckArity(1,1) THEN
type := type0;
IF IsIntegerType(type) THEN
IF type.sizeInBits = 64 THEN Error(parameter0.position,Diagnostics.Invalid,"long not applicable")
ELSE
CASE type.sizeInBits OF
8: type := Global.Integer16
|16: type := Global.Integer32
|32: type := Global.Integer64
END;
END;
ELSIF type IS SyntaxTree.FloatType THEN
IF type.sizeInBits = 64 THEN Error(parameter0.position,Diagnostics.Invalid,"long not applicable")
ELSIF type.sizeInBits = 32 THEN type := Global.Float64
END;
ELSIF type IS SyntaxTree.ComplexType THEN
IF type.sizeInBits = 128 THEN Error(parameter0.position,Diagnostics.Invalid,"long not applicable")
ELSIF type.sizeInBits = 64 THEN type := Global.Complex128
END;
ELSE
Error(parameter0.position,Diagnostics.Invalid,"long not applicable")
END;
IF (parameter0.resolved # NIL) THEN
parameter0 := ConvertValue(parameter0.position,parameter0.resolved,type);
IF parameter0 IS SyntaxTree.Value THEN
result.SetResolved(parameter0(SyntaxTree.Value));
END;
END;
ELSIF (id = Global.systemSizeOf) & CheckArity(1,1) THEN
IF (parameter0.type = SyntaxTree.typeDeclarationType) THEN
type := parameter0(SyntaxTree.SymbolDesignator).symbol(SyntaxTree.TypeDeclaration).declaredType;
result.SetResolved(SyntaxTree.NewIntegerValue(position,system.SizeOf(type.resolved) DIV 8 ));
type := system.integerType;
ELSE
Error(parameter0.position,Diagnostics.Invalid,"is not a type symbol");
END
ELSIF (id = Global.systemTrace) & CheckArity(1,5) THEN
FOR i := 0 TO numberActualParameters-1 DO
parameter0 := actualParameters.GetExpression(i);
IF ~IsBasicType(parameter0.type) & ~IsStringType(parameter0.type) THEN
Error(parameter0.position,Diagnostics.Invalid,"incompatible parameter");
END;
END;
ELSIF (id = Global.systemAdr) & CheckArity(1,1) THEN
IF HasAddress(parameter0) THEN
type := system.addressType;
ELSE
type := SyntaxTree.invalidType;
Error(parameter0.position,Diagnostics.Invalid,"has no address");
END;
ELSIF (id = Global.systemBit) & CheckArity(2,2) THEN
IF CheckIntegerType(parameter0) & CheckIntegerType(parameter1) THEN
parameter0 := NewConversion(parameter0.position,parameter0,system.addressType,NIL);
actualParameters.SetExpression(0,parameter0);
parameter1 := NewConversion(parameter1.position,parameter1,system.addressType,NIL);
actualParameters.SetExpression(1,parameter1);
END;
type := system.booleanType;
ELSIF (id = Global.systemMsk) & CheckArity(2,2) THEN
IF CheckIntegerType(parameter0) & CheckIntegerType(parameter1) THEN
ConvertOperands(parameter0,parameter1);
actualParameters.SetExpression(0,parameter0);
actualParameters.SetExpression(1,parameter1);
END;
type := parameter0.type;
ELSIF (id = Global.systemGet64) & CheckArity(1,1) THEN
IF CheckIntegerType(parameter0) THEN
parameter0 := NewConversion(0,parameter0,system.addressType,NIL);
actualParameters.SetExpression(0,parameter0);
END;
type := system.hugeintType;
ELSIF (id = Global.systemGet32) & CheckArity(1,1) THEN
IF CheckIntegerType(parameter0) THEN
parameter0 := NewConversion(0,parameter0,system.addressType,NIL);
actualParameters.SetExpression(0,parameter0);
END;
type := system.longintType;
ELSIF (id = Global.systemGet16) & CheckArity(1,1) THEN
IF CheckIntegerType(parameter0) THEN
parameter0 := NewConversion(0,parameter0,system.addressType,NIL);
actualParameters.SetExpression(0,parameter0);
END;
type := system.integerType;
ELSIF (id = Global.systemGet8) & CheckArity(1,1) THEN
IF CheckIntegerType(parameter0) THEN
parameter0 := NewConversion(0,parameter0,system.addressType,NIL);
actualParameters.SetExpression(0,parameter0);
END;
type := system.shortintType;
ELSIF ((id = Global.systemLsh) OR (id = Global.systemRot)) & CheckArity(2,2) THEN
type := type0;
parameter1 := NewConversion(parameter1.position,parameter1,system.longintType,NIL);
actualParameters.SetExpression(1, parameter1);
IF IsIntegerValue(parameter0,i0) & IsIntegerValue(parameter1,i1) THEN
result.SetResolved(SyntaxTree.NewIntegerValue(position,SYSTEM.LSH(i0,i1)));
END;
ELSIF (id = Global.systemVal) & CheckArity(2,2) THEN
IF CheckTypeDeclarationType(parameter0) THEN
type := parameter0(SyntaxTree.SymbolDesignator).symbol(SyntaxTree.TypeDeclaration).declaredType;
IF (type.resolved IS SyntaxTree.ArrayType) & (type.resolved(SyntaxTree.ArrayType).form # SyntaxTree.Static) THEN
result := SyntaxTree.invalidExpression;
Error(parameter0.position,Diagnostics.Invalid,"is no basic type");
ELSE
IF (parameter1.resolved # NIL) THEN
parameter0 := ConvertValue(parameter1.position,parameter1.resolved,type);
IF parameter0 IS SyntaxTree.Value THEN
result.SetResolved(parameter0(SyntaxTree.Value));
END;
END;
result.SetAssignable(parameter1.assignable);
END;
END;
ELSIF (id = Global.systemGet) & CheckArity(2,2) THEN
IF CheckIntegerType(parameter0) & CheckBasicType(parameter1) & CheckVariable(parameter1) THEN
parameter0 := NewConversion(0,parameter0,system.addressType,NIL);
actualParameters.SetExpression(0,parameter0);
END;
ELSIF (id = Global.systemPut) & CheckArity(2,2) THEN
IF CheckIntegerType(parameter0) & CheckBasicType(parameter1) THEN
parameter0 := NewConversion(0,parameter0,system.addressType,NIL);
actualParameters.SetExpression(0,parameter0);
END;
ELSIF (id = Global.systemPut64) & CheckArity(2,2) THEN
IF CheckIntegerType(parameter0) & CheckBasicType(parameter1) THEN
parameter0 := NewConversion(parameter0.position,parameter0,system.addressType,NIL);
parameter1 := NewConversion(parameter1.position,parameter1,system.hugeintType,NIL);
actualParameters.SetExpression(0,parameter0);
actualParameters.SetExpression(1,parameter1);
END;
ELSIF (id = Global.systemPut32) & CheckArity(2,2) THEN
IF CheckIntegerType(parameter0) & CheckBasicType(parameter1) THEN
parameter0 := NewConversion(parameter0.position,parameter0,system.addressType,NIL);
parameter1 := NewConversion(parameter1.position,parameter1,system.longintType,NIL);
actualParameters.SetExpression(0,parameter0);
actualParameters.SetExpression(1,parameter1);
END;
ELSIF (id = Global.systemPut16) & CheckArity(2,2) THEN
IF CheckIntegerType(parameter0) & CheckBasicType(parameter1) THEN
parameter0 := NewConversion(parameter0.position,parameter0,system.addressType,NIL);
parameter1 := NewConversion(parameter1.position,parameter1,system.integerType,NIL);
actualParameters.SetExpression(0,parameter0);
actualParameters.SetExpression(1,parameter1);
END;
ELSIF (id = Global.systemPut8) & CheckArity(2,2) THEN
IF CheckIntegerType(parameter0) & CheckBasicType(parameter1) THEN
parameter0 := NewConversion(parameter0.position,parameter0,system.addressType,NIL);
parameter1 := NewConversion(parameter1.position,parameter1,system.shortintType,NIL);
actualParameters.SetExpression(0,parameter0);
actualParameters.SetExpression(1,parameter1);
END;
ELSIF (id = Global.systemMove) & CheckArity(3,3) THEN
IF CheckIntegerType(parameter0) & CheckIntegerType(parameter1) & CheckIntegerType(parameter2) THEN
parameter0 := NewConversion(0,parameter0,system.addressType,NIL);
parameter1 := NewConversion(0,parameter1,system.addressType,NIL);
parameter2 := NewConversion(0,parameter2,system.addressType,NIL);
actualParameters.SetExpression(0,parameter0);
actualParameters.SetExpression(1,parameter1);
actualParameters.SetExpression(2,parameter2);
END;
ELSIF (id = Global.systemNew) & CheckArity(2,2) THEN
IF ~IsPointerType(parameter0.type) THEN
Error(parameter0.position,Diagnostics.Invalid,"is not a pointer")
ELSIF CheckIntegerType(parameter1) THEN
parameter1 := NewConversion(Diagnostics.Invalid, parameter1, system.sizeType,NIL);
actualParameters.SetExpression(1,parameter1);
END;
ELSIF (id = Global.systemRef) & CheckArity(1,1) & CheckStringType(parameter0) THEN
type := system.addressType
ELSIF (id = Global.systemIncr) & CheckArity(1,2) THEN
type := system.sizeType;
base := type0;
IF (numberActualParameters =2) & CheckIntegerType(parameter1) THEN
IF ~IsIntegerValue(parameter1,i1) THEN i1 := 0 END;
IF i1 < 0 THEN
Error(position,Diagnostics.Invalid,"invalid dimension");
base := SyntaxTree.invalidType;
ELSE
base := ArrayBase(base,i1);
IF (base # NIL) & Indexable(base) THEN
ELSE
Error(position,Diagnostics.Invalid,"len on no array");
IF VerboseErrorMessage THEN
Printout.Info("base",base);
END;
base := SyntaxTree.invalidType;
END;
END;
parameter1 := NewConversion(parameter1.position,parameter1,system.longintType,NIL);
actualParameters.SetExpression(1,parameter1);
IF (numberActualParameters =2) & (parameter1 IS SyntaxTree.IntegerValue) THEN
mathArrayType := base(SyntaxTree.MathArrayType);
IF (mathArrayType.form = SyntaxTree.Static) THEN
result := SyntaxTree.NewIntegerValue(position,ToMemoryUnits(system,mathArrayType.staticIncrementInBits));
type := system.longintType;
END;
END;
ELSE
type := system.longintType;
END;
ELSIF (id = Global.Sum) & CheckArity(1,2) THEN
HALT(200);
IF numberActualParameters=1 THEN
ELSE
END;
ELSIF (id = Global.Dim) & CheckArity(1,1) THEN
type := system.sizeType;
IF type0 IS SyntaxTree.MathArrayType THEN
IF type0(SyntaxTree.MathArrayType).form # SyntaxTree.Tensor THEN
i := Dimension(type0,{SyntaxTree.Open,SyntaxTree.Static});
result.SetResolved(SyntaxTree.NewIntegerValue(position,i));
END;
ELSE
Error(position,Diagnostics.Invalid,"dimension on non math array type");
END;
ELSIF (id = Global.Reshape) & CheckArity(2,2) THEN
IF type0 IS SyntaxTree.MathArrayType THEN
base := ArrayBase(type0,MAX(LONGINT));
type := SyntaxTree.NewMathArrayType(Diagnostics.Invalid,currentScope,SyntaxTree.Tensor);
type(SyntaxTree.MathArrayType).SetArrayBase(base);
parameterType := SyntaxTree.NewMathArrayType(Diagnostics.Invalid,currentScope,SyntaxTree.Tensor);
parameterType(SyntaxTree.MathArrayType).SetArrayBase(base);
IF ~CompatibleTo(system,type0,parameterType) THEN
Error(parameter0.position,Diagnostics.Invalid,"incompatible parameter in reshape");
result := SyntaxTree.invalidExpression;
ELSE
parameter0 := NewConversion(Diagnostics.Invalid,parameter0,parameterType,NIL); actualParameters.SetExpression(0,parameter0);
END;
parameterType := SyntaxTree.NewMathArrayType(Diagnostics.Invalid,currentScope,SyntaxTree.Open);
parameterType(SyntaxTree.MathArrayType).SetArrayBase(system.longintType);
IF ~CompatibleTo(system,type1,parameterType) THEN
Error(parameter1.position,Diagnostics.Invalid,"parameter incompatible to math array of longint");
result := SyntaxTree.invalidExpression;
ELSE
parameter1 := NewConversion(Diagnostics.Invalid,parameter1,parameterType,NIL); actualParameters.SetExpression(1,parameter1);
END;
ELSE
Error(position, Diagnostics.Invalid,"reshape on non math array type");
result := SyntaxTree.invalidExpression;
END;
ELSIF (id = Global.systemZeroCopy) & CheckArity(2,2) THEN
IF (type0 IS SyntaxTree.MathArrayType) & (type1 IS SyntaxTree.MathArrayType) THEN
IF ~CompatibleTo(system,type1,type0) THEN
Error(parameter0.position,Diagnostics.Invalid,"incompatible parameter in reshape");
result := SyntaxTree.invalidExpression;
END;
ELSE Error(position, Diagnostics.Invalid,"zerocopy on non math array type");
END;
ELSIF (id = Global.systemTypeCode) & CheckArity(1,1) THEN
IF (parameter0.type = SyntaxTree.typeDeclarationType) THEN
type := parameter0(SyntaxTree.SymbolDesignator).symbol(SyntaxTree.TypeDeclaration).declaredType;
type := type.resolved;
IF type IS SyntaxTree.PointerType THEN
type := type(SyntaxTree.PointerType).pointerBase.resolved;
END;
IF ~(type IS SyntaxTree.RecordType) THEN
Error(parameter0.position,Diagnostics.Invalid,"must be type with type descriptor");
END;
ELSE
Error(parameter0.position,Diagnostics.Invalid,"is not a type symbol");
END;
type := system.addressType;
ELSIF (id = Global.systemNull) & CheckArity(1,1) THEN
type := system.booleanType;
ELSIF (id = Global.Flt) & CheckArity(1,1) THEN
type := system.realType;
IF IsRealValue(parameter0, r) THEN
result.SetResolved(SyntaxTree.NewRealValue(position, r));
ELSIF CheckIntegerType(parameter0) & IsIntegerValue(parameter0, i) THEN
i0 := i; i := ABS(i);
IF i # 0 THEN
i1 := 23;
IF i >= 2*800000H THEN
REPEAT i := i DIV 2; INC(i1) UNTIL i < 2*800000H;
ELSIF i < 800000H THEN
REPEAT i := 2 * i; DEC(i1) UNTIL i >= 800000H;
END;
i := (i1 + 127)*800000H - 800000H + i;
IF i0 < 0 THEN i := SYSTEM.VAL(LONGINT, SYSTEM.VAL(SET, i) + {31}); END;
END;
result.SetResolved(SyntaxTree.NewRealValue(position, SYSTEM.VAL(REAL, i)));
END;
ELSIF (id = Global.Floor) & CheckArity(1,1) THEN
type := system.longintType;
IF CheckRealType(parameter0) & IsRealValue(parameter0,r) THEN
result.SetResolved(SyntaxTree.NewIntegerValue(position,ENTIER(r)));
END;
ELSIF (id = Global.systemProc) & CheckArity(2,2) THEN
type := parameter1.type.resolved;
result := parameter0;
ELSIF (id = Global.systemStop) & CheckArity(0,0) THEN
ELSIF ((id = Global.ASR) OR (id = Global.LSR) OR (id = Global.LSL) OR (id = Global.systemROR)) & CheckArity(2,2) THEN
IF CheckIntegerType(parameter0) & CheckIntegerType(parameter1) THEN
type := type0;
END;
type := type0;
ELSIF (id = Global.systemXOR) THEN
IF CheckIntegerType(parameter0) & (type0=type1) THEN
END;
type := type0;
ELSIF (id = Global.Connect) & (CheckArity(2,3)) THEN
IF ~(currentIsCellNet) THEN
Error(position,Diagnostics.Invalid,"connection outside activeCells body block");
END;
IF CheckPortType(parameter0, outPort) & CheckPortType(parameter1, inPort) THEN
IF (outPort.direction # SyntaxTree.OutPort) THEN Error(parameter0.position,Diagnostics.Invalid,"not an out-port") END;
IF (inPort.direction # SyntaxTree.InPort) THEN Error(parameter0.position,Diagnostics.Invalid,"not an in-port") END;
END;
IF numberActualParameters = 3 THEN
IF IsIntegerValue(parameter2,i0) & (i0>=0) THEN
parameter2.SetResolved(SyntaxTree.NewIntegerValue(position,ABS(i0)));
ELSE
Error(position,Diagnostics.Invalid,"incompatible channel size parameter");
END;
END;
activeCellsStatement := TRUE;
ELSIF (id = Global.Delegate) & (CheckArity(2,2)) THEN
IF ~(currentIsCellNet) THEN
Error(position,Diagnostics.Invalid,"connection delegation outside activeCells body block");
END;
IF ~CheckPortType(parameter1, inPort) THEN
Error(parameter0.position,Diagnostics.Invalid,"not a port")
ELSIF ~CheckPortType(parameter0, outPort) THEN
Error(parameter1.position,Diagnostics.Invalid,"not a port")
ELSIF (outPort.direction # inPort.direction) THEN
Error(parameter0.position,Diagnostics.Invalid,"invalid port direction");
ELSIF outPort.sizeInBits # inPort.sizeInBits THEN
Error(position,Diagnostics.Invalid,"incompatible port sizes");
END;
activeCellsStatement := TRUE;
ELSIF (id = Global.Receive) & CheckArity(2,3) THEN
ImportModule(Global.NameChannelModule,position);
IF CheckPortType(parameter0,inPort) & CheckVariable(parameter1) THEN
IF inPort.direction # SyntaxTree.InPort THEN
Error(parameter0.position,Diagnostics.Invalid,"not an in-port")
ELSIF inPort.sizeInBits # system.SizeOf(parameter1.type) THEN
Error(parameter1.position,Diagnostics.Invalid,"incompatible to port type");
END;
IF (numberActualParameters=3) & CheckVariable(parameter2) THEN
IF ~SameType(parameter2.type, system.integerType) THEN
Error(parameter2.position,Diagnostics.Invalid,"incompatible to integer type");
END;
END;
END;
ELSIF (id = Global.Send) & CheckArity(2,2) THEN
ImportModule(Global.NameChannelModule,position);
IF CheckPortType(parameter0,outPort) THEN
IF outPort.direction # SyntaxTree.OutPort THEN
Error(parameter1.position,Diagnostics.Invalid,"not an out-port")
ELSIF outPort.sizeInBits # system.SizeOf(parameter1.type) THEN
Error(parameter1.position,Diagnostics.Invalid,"incompatible to port type");
ELSE
parameter1 := NewConversion(position,parameter1,parameter0.type.resolved,NIL);
actualParameters.SetExpression(1,parameter1);
END;
END;
ELSIF (id = Global.systemHardwareAddress) & (CheckArity(1,1)) THEN
IF CheckStringValue(parameter0,name) THEN
device := activeCellsSpecification.supportedDevices.ByName(name^);
IF device = NIL THEN
Error(parameter0.position,Diagnostics.Invalid,"unsupported device");
result := SyntaxTree.invalidExpression;
ELSE
result := Global.NewIntegerValue(system,parameter0.position,device.adr);
type := result.type;
END;
END;
ELSIF id = Global.systemSpecial THEN
customBuiltin := builtin(SyntaxTree.CustomBuiltin);
ASSERT(customBuiltin.type IS SyntaxTree.ProcedureType);
procedureType := customBuiltin.type(SyntaxTree.ProcedureType);
type := procedureType.returnType;
IF CheckArity(procedureType.numberParameters, procedureType.numberParameters) THEN
formalParameter := procedureType.firstParameter;
FOR i := 0 TO actualParameters.Length() - 1 DO
actualParameter := actualParameters.GetExpression(i);
IF actualParameter = SyntaxTree.invalidExpression THEN
ELSIF ~ParameterCompatible(formalParameter,actualParameter) THEN
Error(position,Diagnostics.Invalid, "incompatible parameter")
ELSE
actualParameter := NewConversion(actualParameter.position, actualParameter, formalParameter.type, NIL)
END;
actualParameters.SetExpression(i, actualParameter);
formalParameter := formalParameter.nextParameter
END
END
ELSE
Error(position,Diagnostics.Invalid,"builtin not implemented");
result := SyntaxTree.invalidExpression;
END;
END;
IF result # SyntaxTree.invalidExpression THEN
type := ResolveType(type);
IF result.resolved # NIL THEN result.resolved.SetType(type) END;
result.SetType(type);
END;
RETURN result
END NewBuiltinCallDesignator;
PROCEDURE NewTypeGuardDesignator(position: LONGINT; left: SyntaxTree.Designator; type: SyntaxTree.Type): SyntaxTree.Designator;
VAR result: SyntaxTree.Designator;
BEGIN
result := SyntaxTree.invalidDesignator;
IF ~IsTypeExtension(left.type.resolved,type.resolved) THEN
Error(position,Diagnostics.Invalid,"no type extension of type");
IF VerboseErrorMessage THEN
Printout.Info("left",left);
Printout.Info("type",type);
END;
ELSIF ~(left.type.resolved = type.resolved) & ~IsExtensibleDesignator(left) THEN
Error(position,Diagnostics.Invalid,"variable cannot be extended");
ELSE
result := SyntaxTree.NewTypeGuardDesignator(position,left,type);
result.SetType(type);
result.SetAssignable(left.assignable);
END;
RETURN result
END NewTypeGuardDesignator;
PROCEDURE VisitParameterDesignator(designator: SyntaxTree.ParameterDesignator);
VAR
parameters: SyntaxTree.ExpressionList;
left: SyntaxTree.Designator;
result,expression: SyntaxTree.Expression;
typeDeclaration: SyntaxTree.TypeDeclaration;
BEGIN
IF Trace THEN D.Str("VisitParameterDesignator"); D.Ln; END;
result := SyntaxTree.invalidDesignator;
left := ResolveDesignator(designator.left);
IF left # SyntaxTree.invalidDesignator THEN
parameters := designator.parameters;
IF ExpressionList(parameters) THEN
IF IsExtensibleDesignator(left) & (parameters.Length()=1) & IsTypeDesignator(parameters.GetExpression(0),typeDeclaration) THEN
result := NewTypeGuardDesignator(designator.position,left,typeDeclaration.declaredType)
ELSIF IsUnextensibleRecord(left) & (parameters.Length()=1) & IsTypeDesignator(parameters.GetExpression(0),typeDeclaration) & (typeDeclaration.declaredType.resolved = left.type.resolved) THEN
result := NewTypeGuardDesignator(designator.position,left,typeDeclaration.declaredType)
ELSIF (left.type.resolved IS SyntaxTree.ProcedureType) THEN
IF (left IS SyntaxTree.SymbolDesignator) & (left(SyntaxTree.SymbolDesignator).symbol IS SyntaxTree.Builtin) THEN
result := NewBuiltinCallDesignator(designator.position,left(SyntaxTree.SymbolDesignator).symbol(SyntaxTree.Builtin),parameters,left);
ELSE
result := NewProcedureCallDesignator(designator.position,left,parameters)
END
ELSIF IsTypeDesignator(left,typeDeclaration) & (parameters.Length()=1) THEN
expression := parameters.GetExpression(0);
IF (typeDeclaration.declaredType.resolved IS SyntaxTree.NumberType) & ((expression.type.resolved IS SyntaxTree.NumberType) OR (expression.type.resolved IS SyntaxTree.AddressType) OR (expression.type.resolved IS SyntaxTree.SizeType)) THEN
result := NewConversion(designator.position,expression,typeDeclaration.declaredType,left)
ELSE
Error(left.position,Diagnostics.Invalid,"invalid type in explicit conversion");
END;
ELSE
Error(left.position,Diagnostics.Invalid,"called object is not a procedure or cannot be extended");
IF VerboseErrorMessage THEN Printout.Info("designator",designator); Printout.Info("left",left) END;
result := SyntaxTree.invalidDesignator;
END;
ELSE
result := SyntaxTree.invalidDesignator
END;
END;
resolvedExpression := result;
END VisitParameterDesignator;
PROCEDURE NewDereferenceDesignator(position: LONGINT; left: SyntaxTree.Designator): SyntaxTree.Designator;
VAR type: SyntaxTree.Type; result: SyntaxTree.Designator;
BEGIN
result := SyntaxTree.invalidDesignator;
type := left.type;
IF (type # NIL) & ((type.resolved IS SyntaxTree.PointerType)) THEN
type := type.resolved(SyntaxTree.PointerType).pointerBase;
result := SyntaxTree.NewDereferenceDesignator(position,left);
result.SetAssignable(TRUE);
result.SetType(type);
ELSE
Error(position,Diagnostics.Invalid,"dereference on no pointer");
END;
RETURN result
END NewDereferenceDesignator;
PROCEDURE NewSupercallDesignator(position: LONGINT; left: SyntaxTree.Designator): SyntaxTree.Designator;
VAR result: SyntaxTree.Designator; symbol: SyntaxTree.Symbol; procedure: SyntaxTree.Procedure;
objectScope: SyntaxTree.Scope;
BEGIN
result := SyntaxTree.invalidDesignator;
IF left = SyntaxTree.invalidDesignator THEN
ELSIF left IS SyntaxTree.SymbolDesignator THEN
symbol := left(SyntaxTree.SymbolDesignator).symbol;
ASSERT(symbol # SyntaxTree.invalidSymbol);
IF symbol IS SyntaxTree.Procedure THEN
procedure := symbol(SyntaxTree.Procedure);
objectScope := currentScope;
WHILE (objectScope # NIL) & ~(objectScope IS SyntaxTree.RecordScope) DO
objectScope := objectScope.outerScope;
END;
IF (left.left = NIL) OR ~
(
(left.left IS SyntaxTree.SelfDesignator) OR
(left.left IS SyntaxTree.DereferenceDesignator)
& (left.left(SyntaxTree.Designator).left # NIL)
& (left.left(SyntaxTree.Designator).left IS SyntaxTree.SelfDesignator)) OR (procedure.scope # objectScope) THEN
Error(position,Diagnostics.Invalid,"procedure not in immediate object scope");
IF VerboseErrorMessage THEN
Printout.Info("left.left",left.left);
END;
ELSIF procedure.super # NIL THEN
result := SyntaxTree.NewSupercallDesignator(position,left);
result.SetType(left.type.resolved)
ELSE
Error(position,Diagnostics.Invalid,"no supermethod for this procedure");
END;
ELSE
Error(position,Diagnostics.Invalid,"symbol is not a procedure");
END;
ELSE
Error(position,Diagnostics.Invalid,"is no symbol designator");
END;
RETURN result
END NewSupercallDesignator;
PROCEDURE VisitArrowDesignator(arrowDesignator: SyntaxTree.ArrowDesignator);
VAR left: SyntaxTree.Designator;
BEGIN
IF Trace THEN D.Str("VisitArrowDesignator"); D.Ln; END;
left := ResolveDesignator(arrowDesignator.left);
IF left # NIL THEN
IF (left.type = NIL) THEN
Error(arrowDesignator.position,Diagnostics.Invalid,"Invalid arrow designator");
ELSIF (left.type.resolved # NIL) & (left.type.resolved IS SyntaxTree.ProcedureType) THEN
resolvedExpression := NewSupercallDesignator(arrowDesignator.position,left);
ELSE
resolvedExpression := NewDereferenceDesignator(arrowDesignator.position,left)
END
END
END VisitArrowDesignator;
PROCEDURE ResolveExpression(expression: SyntaxTree.Expression): SyntaxTree.Expression;
VAR result,prev: SyntaxTree.Expression;
BEGIN
IF expression = NIL THEN result := NIL
ELSIF (expression.type = NIL) THEN
prev := resolvedExpression;
resolvedExpression := SyntaxTree.invalidExpression;
expression.SetType(SyntaxTree.invalidType);
expression.Accept(SELF);
result := resolvedExpression;
IF currentIsRealtime THEN
IF (result.type # NIL) & ~result.type.resolved.isRealtime THEN
Error(expression.position,Diagnostics.Invalid,"forbidden non-realtime expression in realtime procedure");
END;
END;
resolvedExpression := prev
ELSE
result := expression
END;
RETURN result
END ResolveExpression;
PROCEDURE ConstantExpression(expression: SyntaxTree.Expression): SyntaxTree.Expression;
VAR position: LONGINT;
BEGIN
position := expression.position;
expression := ResolveExpression(expression);
IF expression = SyntaxTree.invalidExpression THEN
ELSIF (expression.resolved = NIL) THEN
Error(position,Diagnostics.Invalid,"expression is not constant");
IF VerboseErrorMessage THEN Printout.Info("expression",expression); END;
expression := SyntaxTree.invalidExpression;
END;
RETURN expression
END ConstantExpression;
PROCEDURE ConstantInteger(expression: SyntaxTree.Expression): SyntaxTree.Expression;
VAR position: LONGINT;
BEGIN
position := expression.position;
expression := ResolveExpression(expression);
IF expression = SyntaxTree.invalidExpression THEN
ELSIF (expression.resolved = NIL) OR ~(expression.resolved IS SyntaxTree.IntegerValue) THEN
expression := SyntaxTree.invalidExpression;
Error(position,Diagnostics.Invalid,"expression is not a constant integer");
END;
RETURN expression
END ConstantInteger;
PROCEDURE ConstantIntegerGeq0(expression: SyntaxTree.Expression): SyntaxTree.Expression;
VAR position: LONGINT;
BEGIN
position := expression.position;
expression := ConstantExpression(expression);
IF expression = SyntaxTree.invalidExpression THEN
ELSIF (expression.resolved = NIL) OR ~(expression.resolved IS SyntaxTree.IntegerValue) THEN
Error(position,Diagnostics.Invalid,"expression is not integer valued");
expression := SyntaxTree.invalidExpression
ELSIF (expression.resolved(SyntaxTree.IntegerValue).hvalue <0) THEN
Error(position,Diagnostics.Invalid,"integer is not greater or equal zero");
END;
RETURN expression
END ConstantIntegerGeq0;
PROCEDURE ResolveCondition(expression: SyntaxTree.Expression): SyntaxTree.Expression;
VAR position: LONGINT;
BEGIN
position := expression.position;
expression := ResolveExpression(expression);
IF expression = SyntaxTree.invalidExpression THEN
ELSIF (expression.type = NIL) OR ~(expression.type.resolved IS SyntaxTree.BooleanType) THEN
expression := SyntaxTree.invalidExpression;
Error(position,Diagnostics.Invalid,"expression is not boolean");
END;
RETURN expression
END ResolveCondition;
PROCEDURE ResolveSymbol(x: SyntaxTree.Symbol);
BEGIN
x.Accept(SELF);
END ResolveSymbol;
PROCEDURE CheckSymbolVisibility(symbol: SyntaxTree.Symbol);
VAR scope: SyntaxTree.Scope;
BEGIN
scope := symbol.scope;
WHILE (scope # NIL) & ~(scope IS SyntaxTree.ProcedureScope) DO
scope := scope.outerScope;
END;
IF (scope # NIL) THEN
IF (symbol.access * SyntaxTree.Public # {}) & (~(symbol IS SyntaxTree.Procedure) OR ~symbol(SyntaxTree.Procedure).isBodyProcedure & ~symbol(SyntaxTree.Procedure).isConstructor) THEN
Error(symbol.position,Diagnostics.Invalid,"cannot be exported");
IF VerboseErrorMessage THEN
Printout.Info("symbol",symbol);
END;
END;
END;
END CheckSymbolVisibility;
PROCEDURE SymbolNeedsResolution(x: SyntaxTree.Symbol): 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 SymbolNeedsResolution;
PROCEDURE VisitTypeDeclaration(typeDeclaration: SyntaxTree.TypeDeclaration);
BEGIN
IF Trace THEN D.Str("VisitTypeDeclaration "); D.Str0(typeDeclaration.name); D.Ln; END;
IF SymbolNeedsResolution(typeDeclaration) THEN
typeDeclaration.SetType(SyntaxTree.typeDeclarationType);
typeDeclaration.SetDeclaredType(ResolveType(typeDeclaration.declaredType));
CheckSymbolVisibility(typeDeclaration);
typeDeclaration.SetState(SyntaxTree.Resolved);
END;
END VisitTypeDeclaration;
PROCEDURE VisitConstant(constant: SyntaxTree.Constant);
VAR
expression: SyntaxTree.Expression;
type: SyntaxTree.Type;
BEGIN
IF Trace THEN D.Str("VisitConstant "); D.Str0(constant.name); D.Ln; END;
IF SymbolNeedsResolution(constant) THEN
constant.SetType(SyntaxTree.invalidType);
expression := ConstantExpression(constant.value);
ASSERT(expression.type # NIL);
type := expression.type.resolved;
constant.SetType(type);
constant.SetValue(expression);
CheckSymbolVisibility(constant);
constant.SetState(SyntaxTree.Resolved);
END;
END VisitConstant;
PROCEDURE AdaptStackAlignment(procedure: SyntaxTree.Procedure; alignment: LONGINT);
VAR procedureAlignment: LONGINT;
PROCEDURE LCM(a0,b0: LONGINT): LONGINT;
VAR a,b: LONGINT;
BEGIN
a := a0; b := b0;
WHILE (a # b) DO
IF a < b THEN a := a+a0
ELSE b := b + b0
END;
END;
RETURN a
END LCM;
BEGIN
IF alignment > 1 THEN
procedureAlignment := procedure.type(SyntaxTree.ProcedureType).stackAlignment;
IF (procedureAlignment > 1) THEN
alignment := LCM(alignment, procedureAlignment);
END;
procedure.type(SyntaxTree.ProcedureType).SetStackAlignment(alignment);
END;
END AdaptStackAlignment;
PROCEDURE VisitVariable(variable: SyntaxTree.Variable);
VAR modifiers: SyntaxTree.Modifier; value,position: LONGINT;
BEGIN
IF Trace THEN D.Str("VisitVariable "); D.Str0(variable.name); D.Ln; END;
IF SymbolNeedsResolution(variable) THEN
modifiers := variable.modifiers;
variable.SetType(ResolveType(variable.type));
IF variable.type.resolved IS SyntaxTree.ArrayType THEN
IF variable.type.resolved(SyntaxTree.ArrayType).length = NIL THEN
Error(variable.position,Diagnostics.Invalid,"forbidden open array variable");
END;
END;
CheckSymbolVisibility(variable);
IF HasFlag(modifiers, Global.NameUntraced,position) THEN
variable.SetUntraced(TRUE);
IF ~ContainsPointer(variable.type) THEN
IF VerboseErrorMessage THEN Printout.Info("variable",variable); Printout.Info("variable.type",variable.type.resolved); END;
Error(position,Diagnostics.Invalid,"untraced flag on non-pointer variable");
END;
END;
IF HasValue(modifiers, Global.NameAligned,position, value) THEN
IF (variable.scope IS SyntaxTree.ProcedureScope) THEN
IF ~PowerOf2(value) THEN
Error(position,Diagnostics.Invalid,"forbidden alignment - must be power of two");
ELSE
AdaptStackAlignment(variable.scope(SyntaxTree.ProcedureScope).ownerProcedure, value);
END;
END;
variable.SetAlignment(FALSE,value);
ELSIF HasValue(modifiers, Global.NameFixed,position, value) THEN
IF (variable.scope IS SyntaxTree.ProcedureScope) THEN
Error(position,Diagnostics.Invalid,"fixed position not possible in procedure");
END;
variable.SetAlignment(TRUE, value);
END;
IF variable.type.resolved IS SyntaxTree.CellType THEN
IF HasValue(modifiers, Global.NameCodeMemorySize, position, value) THEN END;
IF HasValue(modifiers, Global.NameDataMemorySize, position, value) THEN END;
END;
CheckModifiers(modifiers);
variable.SetState(SyntaxTree.Resolved);
END;
END VisitVariable;
PROCEDURE VisitParameter(parameter: SyntaxTree.Parameter);
VAR expression: SyntaxTree.Expression;
BEGIN
IF Trace THEN D.Str("VisitParameter "); D.Str0(parameter.name); D.Ln; END;
IF SymbolNeedsResolution(parameter) THEN
parameter.SetType(ResolveType(parameter.type));
ASSERT(parameter.type.resolved # NIL);
CheckSymbolVisibility(parameter);
IF parameter.kind = SyntaxTree.ConstParameter THEN parameter.SetAccess(parameter.access * SyntaxTree.ReadOnly) END;
IF parameter.ownerType IS SyntaxTree.CellType THEN
parameter.SetAccess(SyntaxTree.ReadOnly);
END;
IF parameter.defaultValue # NIL THEN
IF parameter.kind # SyntaxTree.ValueParameter THEN
Error(parameter.position,Diagnostics.Invalid,"forbidden default value on non-value parameter");
ELSE
expression := ConstantExpression(parameter.defaultValue);
IF CompatibleTo(system,expression.type, parameter.type) THEN
expression := NewConversion(expression.position, expression, parameter.type, NIL);
parameter.SetDefaultValue(expression);
END;
END;
END;
parameter.SetState(SyntaxTree.Resolved);
END;
END VisitParameter;
PROCEDURE VisitProcedure(procedure: SyntaxTree.Procedure);
VAR super,testsuper,proc: SyntaxTree.Procedure; record: SyntaxTree.RecordType;
procedureType: SyntaxTree.ProcedureType;
selfParameter: SyntaxTree.Parameter; qualifiedIdentifier: SyntaxTree.QualifiedIdentifier;
qualifiedType: SyntaxTree.QualifiedType; recentFlags: SET; flags: SET;
alignmentExpression,fixedExpression: SyntaxTree.Expression;value: LONGINT;
modifiers: SyntaxTree.Modifier; recentIsRealtime, recentIsBodyProcedure: BOOLEAN;
position: LONGINT;
BEGIN
IF Trace THEN D.Str("VisitProcedure "); D.Str0(procedure.name); D.Ln; END;
IF SymbolNeedsResolution(procedure) THEN
recentIsRealtime := currentIsRealtime;
recentIsBodyProcedure := currentIsBodyProcedure;
IF Trace THEN D.Str("undefined"); D.Ln; END;
procedureType := procedure.type(SyntaxTree.ProcedureType);
modifiers := procedureType.modifiers;
IF HasFlag(modifiers, Global.NameWinAPI,position) THEN procedureType.SetCallingConvention(SyntaxTree.WinAPICallingConvention)
ELSIF HasFlag(modifiers, Global.NameC,position) THEN
IF useDarwinCCalls THEN
procedureType.SetCallingConvention(SyntaxTree.DarwinCCallingConvention)
ELSE
procedureType.SetCallingConvention(SyntaxTree.CCallingConvention)
END
END;
IF HasFlag(modifiers, Global.NameInterrupt, position) THEN
procedureType.SetInterrupt(TRUE);
procedureType.SetCallingConvention(SyntaxTree.InterruptCallingConvention)
END;
IF HasValue(modifiers, Global.NamePcOffset, position, value) THEN procedureType.SetPcOffset(value) END;
IF HasFlag(modifiers,Global.NameNoPAF,position) THEN procedureType.SetNoPAF(TRUE) END;
IF HasFlag(modifiers, Global.NameEntry,position) THEN procedure.SetEntry(TRUE)
ELSIF (procedure.scope IS SyntaxTree.ModuleScope) & HasFlag(modifiers, Global.NameExit, position) THEN procedure.SetExit(TRUE)
END;
IF HasValue(modifiers,Global.NameAligned,position,value) THEN procedure.SetAlignment(FALSE,value)
ELSIF HasValue(modifiers,Global.NameFixed,position,value) THEN procedure.SetAlignment(TRUE,value)
END;
IF HasValue(modifiers,Global.NameStackAligned,value,position) THEN
IF ~PowerOf2(value) THEN
Error(position,Diagnostics.Invalid,"forbidden stack alignment - must be power of two");
ELSE
procedureType.SetStackAlignment(value)
END;
END;
IF HasFlag(modifiers,Global.NameRealtime,position) THEN procedureType.SetRealtime(TRUE) END;
IF HasFlag(modifiers,Global.NameFinal,position) THEN procedure.SetFinal(TRUE)
ELSIF HasFlag(modifiers,Global.NameAbstract,position) THEN procedure.SetAbstract(TRUE)
END;
CheckModifiers(modifiers);
FixProcedureType(procedureType);
currentIsRealtime := procedureType.isRealtime;
currentIsBodyProcedure := procedure.isBodyProcedure;
IF ~system.GenerateParameterOffsets(procedure,FALSE)
THEN
Error(procedure.position,Diagnostics.Invalid,"problems during parameter offset computation");
END;
CheckSymbolVisibility(procedure);
IF procedure.scope IS SyntaxTree.ProcedureScope THEN
procedure.SetLevel(procedure.scope(SyntaxTree.ProcedureScope).ownerProcedure.level+1);
IF ~system.GenerateParameterOffsets(procedure,TRUE) THEN
Error(procedure.position,Diagnostics.Invalid,"problem during parameter offset generation");
END;
END;
IF procedure.scope IS SyntaxTree.RecordScope THEN
record := procedure.scope(SyntaxTree.RecordScope).ownerRecord;
procedureType.SetDelegate(TRUE);
selfParameter := SyntaxTree.NewParameter(procedure.position,procedureType,Global.SelfParameterName,SyntaxTree.ValueParameter);
IF record.pointerType.typeDeclaration = NIL THEN
selfParameter.SetType(record.pointerType);
ELSE
qualifiedIdentifier := SyntaxTree.NewQualifiedIdentifier(procedure.position,SyntaxTree.invalidIdentifier,record.pointerType.typeDeclaration.name);
qualifiedType := SyntaxTree.NewQualifiedType(procedure.position,procedure.scope,qualifiedIdentifier);
qualifiedType.SetResolved(record.pointerType);
selfParameter.SetType(qualifiedType);
END;
selfParameter.SetAccess(SyntaxTree.Hidden);
IF procedure.isConstructor THEN
procedure.MarkUsed;
IF procedureType.returnType # NIL THEN
Error(procedure.position,Diagnostics.Invalid,"constructor with forbidden return type");
END;
proc := procedure.scope.firstProcedure;
WHILE (proc # NIL) & ((proc = procedure) OR ~(proc.isConstructor)) DO
proc := proc.nextProcedure;
END;
IF proc # NIL THEN
Error(procedure.position,Diagnostics.Invalid,"duplicate constructor")
ELSE
procedure.scope(SyntaxTree.RecordScope).SetConstructor(procedure);
END;
END;
super := FindSuperProcedure(record.recordScope, procedure);
IF (super # NIL) & SignatureCompatible(procedure.position,procedureType,super.type.resolved(SyntaxTree.ProcedureType)) THEN
IF (super.isConstructor) & ~(procedure.isConstructor) THEN
Error(procedure.position,Diagnostics.Invalid,"incompatible signature: non-constructor extends constructor");
END;
IF super.isFinal THEN
Error(procedure.position,Diagnostics.Invalid,"forbidden method extending final method");
END;
procedure.SetSuper(super);
super.SetOverwritten(TRUE);
procedure.SetAccess(procedure.access+super.access);
procedure.MarkUsed;
END;
IF ~system.GenerateParameterOffsets(procedure,FALSE)
THEN
Error(procedure.position,Diagnostics.Invalid,"problems during parameter offset computation");
END;
ELSIF procedure.scope IS SyntaxTree.CellScope THEN
IF procedure.isConstructor THEN
procedure.scope(SyntaxTree.CellScope).SetConstructor(procedure);
END;
ELSIF procedure.isConstructor THEN
Error(procedure.position,Diagnostics.Invalid,"procedure illegaly marked as initializer - not in object scope");
END;
Declarations(procedure.procedureScope);
procedure.SetState(SyntaxTree.Resolved);
currentIsRealtime := recentIsRealtime;
currentIsBodyProcedure := recentIsBodyProcedure;
END;
END VisitProcedure;
PROCEDURE VisitBuiltin(builtinProcedure: SyntaxTree.Builtin);
VAR type: SyntaxTree.Type;
BEGIN
type := ResolveType(builtinProcedure.type);
END VisitBuiltin;
PROCEDURE VisitOperator(operator: SyntaxTree.Operator);
VAR
procedureType: SyntaxTree.ProcedureType;
leftType, rightType: SyntaxTree.Type;
identifierNumber, position, i: LONGINT;
hasReturnType, mustBeUnary, mustBeBinary, mustReturnBoolean, mustReturnInteger, mustHaveEquitypedOperands: BOOLEAN;
modifiers: SyntaxTree.Modifier;
super: SyntaxTree.Operator;
PROCEDURE IsLocallyDefined(type: SyntaxTree.Type): BOOLEAN;
BEGIN
IF type = NIL THEN
RETURN FALSE
ELSIF (type.typeDeclaration # NIL) & (type.typeDeclaration.scope.ownerModule = currentScope.ownerModule) THEN
RETURN TRUE
ELSIF (type.resolved IS SyntaxTree.ArrayType) THEN
RETURN IsLocallyDefined(type.resolved(SyntaxTree.ArrayType).arrayBase)
ELSIF (type.resolved IS SyntaxTree.MathArrayType) THEN
RETURN IsLocallyDefined(type.resolved(SyntaxTree.MathArrayType).arrayBase)
ELSE
RETURN FALSE
END
END IsLocallyDefined;
BEGIN
ASSERT(operator.type IS SyntaxTree.ProcedureType);
procedureType := operator.type(SyntaxTree.ProcedureType);
modifiers := procedureType.modifiers;
IF HasFlag(modifiers, Global.NameDynamic, position) THEN operator.SetDynamic(TRUE) END;
CheckModifiers(modifiers);
VisitProcedure(operator);
IF operator.scope IS SyntaxTree.RecordScope THEN
ELSIF operator.scope IS SyntaxTree.ModuleScope THEN
identifierNumber := Global.GetSymbol(operator.scope.ownerModule.case, operator.name);
IF identifierNumber = -1 THEN
Error(operator.position, Diagnostics.Invalid, "operator with unknown identifier")
ELSIF ~system.operatorDefined[identifierNumber] THEN
Error(operator.position, Diagnostics.Invalid, "identifier may not be used for operator")
ELSE
IF procedureType.numberParameters < 1 THEN
Error(operator.position, Diagnostics.Invalid, "operator without operand");
ELSIF procedureType.numberParameters > 2 THEN
Error(operator.position, Diagnostics.Invalid, "operator with more than two operands");
ELSE
leftType := procedureType.firstParameter.type;
IF procedureType.numberParameters > 1 THEN
rightType := procedureType.firstParameter.nextParameter.type
ELSE
rightType := NIL
END;
IF currentScope.ownerModule.name # Global.ArrayBaseName THEN
IF ~(IsLocallyDefined(leftType) OR IsLocallyDefined(rightType)) THEN
Error(operator.position, Diagnostics.Invalid, "none of the operands is declared in the same module")
END
END;
hasReturnType := TRUE;
mustBeUnary := FALSE;
mustBeBinary := FALSE;
mustReturnBoolean := FALSE;
mustReturnInteger := FALSE;
mustHaveEquitypedOperands := FALSE;
CASE identifierNumber OF
| Scanner.Equal, Scanner.Unequal, Scanner.Less, Scanner.LessEqual, Scanner.Greater, Scanner.GreaterEqual:
mustBeBinary := TRUE; mustReturnBoolean := TRUE;
| Scanner.DotEqual, Scanner.DotUnequal, Scanner.DotLess, Scanner.DotLessEqual, Scanner.DotGreater, Scanner.DotGreaterEqual:
mustBeBinary := TRUE
| Scanner.In: mustBeBinary := TRUE; mustReturnBoolean := TRUE
| Scanner.Is: mustBeBinary := TRUE; mustReturnBoolean := TRUE
| Scanner.Times: mustBeBinary := TRUE
| Scanner.TimesTimes: mustBeBinary := TRUE
| Scanner.DotTimes: mustBeBinary := TRUE
| Scanner.PlusTimes: mustBeBinary := TRUE
| Scanner.Slash: mustBeBinary := TRUE
| Scanner.Backslash: mustBeBinary := TRUE
| Scanner.DotSlash: mustBeBinary := TRUE
| Scanner.Div, Scanner.Mod: mustBeBinary := TRUE;
| Scanner.And, Scanner.Or: mustBeBinary := TRUE;
| Scanner.Not: mustBeUnary := TRUE
| Scanner.Plus, Scanner.Minus:
| Scanner.Becomes: mustBeBinary := TRUE; hasReturnType := FALSE;
| Scanner.Transpose: mustBeUnary := TRUE;
| Global.Conversion: mustBeUnary := TRUE;
| Global.DotTimesPlus: mustBeBinary := TRUE;
| Global.AtMulDec, Global.AtMulInc: mustBeBinary := TRUE;
| Global.DecMul, Global.IncMul: mustBeBinary := TRUE;
| Global.Dec, Global.Inc: hasReturnType := FALSE;
| Global.Excl, Global.Incl:
| Global.Abs: mustBeUnary := TRUE;
| Global.Ash:
| Global.Cap:
| Global.Chr: mustBeUnary := TRUE;
| Global.Entier:
| Global.EntierH:
| Global.Len:
| Global.Short, Global.Long: mustBeUnary := TRUE;
| Global.Max, Global.Min:
| Global.Odd:
| Global.Sum:
| Global.Dim: mustBeUnary := TRUE; mustReturnInteger := TRUE;
END;
IF mustBeUnary & (procedureType.numberParameters # 1) THEN
Error(operator.position, Diagnostics.Invalid,"operator is not unary")
ELSIF mustBeBinary & (procedureType.numberParameters # 2) THEN
Error(operator.position, Diagnostics.Invalid,"operator is not binary")
END;
IF mustHaveEquitypedOperands & (procedureType.numberParameters = 2) THEN
leftType := procedureType.firstParameter.type;
rightType := procedureType.firstParameter.nextParameter.type;
IF ~leftType.resolved.SameType(rightType.resolved) THEN
Error(operator.position,Diagnostics.Invalid, "the two operands are not of the same type")
END
END;
IF hasReturnType THEN
IF procedureType.returnType = NIL THEN
Error(operator.position, Diagnostics.Invalid, "return type required")
ELSIF mustReturnBoolean THEN
IF ~(procedureType.returnType.resolved IS SyntaxTree.BooleanType) THEN
Error(operator.position, Diagnostics.Invalid,"return type is not Boolean")
END
ELSIF mustReturnInteger THEN
IF ~(procedureType.returnType.resolved IS SyntaxTree.IntegerType) THEN
Error(operator.position, Diagnostics.Invalid,"return type is not integer")
END
END
ELSIF procedureType.returnType # NIL THEN
Error(operator.position, Diagnostics.Invalid, "return type not allowed")
END
END
END
END
END VisitOperator;
PROCEDURE AddImport*(module: SyntaxTree.Module; x: SyntaxTree.Import): BOOLEAN;
VAR prevScope: SyntaxTree.Scope; prevDiagnostics: Diagnostics.Diagnostics;
BEGIN
IF error THEN RETURN FALSE END;
prevScope := currentScope;
prevDiagnostics := diagnostics;
diagnostics := NIL;
currentScope := module.moduleScope;
VisitImport(x);
IF ~error THEN
module.moduleScope.AddImport(x);
x.SetScope(module.moduleScope);
END;
currentScope := prevScope;
diagnostics := prevDiagnostics;
IF error THEN error := FALSE; RETURN FALSE ELSE RETURN TRUE END;
END AddImport;
PROCEDURE VisitImport(x: SyntaxTree.Import);
VAR
module: SyntaxTree.Module;
moduleScope: SyntaxTree.ModuleScope;
import,reimport: SyntaxTree.Import;
filename: FileName;
BEGIN
IF SymbolNeedsResolution(x) THEN
x.SetType(SyntaxTree.importType);
moduleScope := currentScope.ownerModule.moduleScope;
IF (x.moduleName=Global.SystemName) THEN x.SetModule(system.systemModule[Scanner.Uppercase])
ELSIF (x.moduleName=Global.systemName) THEN x.SetModule(system.systemModule[Scanner.Lowercase])
ELSIF (x.moduleName=currentScope.ownerModule.name) & (x.context=currentScope.ownerModule.context) THEN
Error(x.position,Diagnostics.Invalid,"forbidden self import");
ELSE
IF (x.module = NIL) & (importCache # NIL) THEN
import := importCache.ImportByModuleName(x.moduleName,x.context);
ELSE import := NIL
END;
IF x.module # NIL THEN
module := x.module;
ELSIF import # NIL THEN
module := import.module;
ASSERT(module # NIL);
x.SetModule(module);
ELSE
Global.ModuleFileName(x.moduleName,x.context,filename);
IF symbolFileFormat # NIL THEN
module := symbolFileFormat.Import(filename,importCache);
IF module = NIL THEN
ErrorSS(x.position,"could not import",filename);
IF VerboseErrorMessage THEN
Printout.Info("import",x)
END
ELSE
x.SetModule(module);
IF importCache # NIL THEN
import := SyntaxTree.NewImport(InvalidPosition,x.moduleName,x.moduleName,FALSE);
import.SetContext(x.context);
import.SetModule(module);
importCache.AddImport(import);
END;
END;
ELSE
ErrorSS(x.position,"no symbol file specified: cannot import",filename);
END;
END;
IF module # NIL THEN
IF SELF.module = NIL THEN
END;
import := module.moduleScope.firstImport;
WHILE(import # NIL) DO
ASSERT(import.moduleName # SyntaxTree.invalidIdentifier);
ASSERT(currentScope # NIL);
ASSERT(currentScope.ownerModule # NIL);
ASSERT(import.context # SyntaxTree.invalidIdentifier);
IF (import.moduleName=currentScope.ownerModule.name) & (import.context=currentScope.ownerModule.context) THEN
Error(x.position,Diagnostics.Invalid,"recursive import");
ELSE
IF import.context = SyntaxTree.invalidIdentifier THEN import.SetContext(x.context) END;
reimport := moduleScope.ImportByModuleName(import.moduleName,import.context);
IF reimport = NIL THEN
reimport := SyntaxTree.NewImport(InvalidPosition,import.moduleName,import.moduleName,FALSE);
reimport.SetContext(import.context);
reimport.SetModule(import.module);
moduleScope.AddImport(reimport);
reimport.SetScope(moduleScope);
ELSE
ASSERT(import.module # NIL);
reimport.SetModule(import.module);
END;
END;
import := import.nextImport;
END;
END;
END;
x.SetState(SyntaxTree.Resolved);
END;
END VisitImport;
PROCEDURE ResolveStatement(x: SyntaxTree.Statement): SyntaxTree.Statement;
VAR prev,resolved: SyntaxTree.Statement;
BEGIN
prev := resolvedStatement;
resolvedStatement := x;
IF currentIsUnreachable THEN x.SetUnreachable(TRUE) END;
activeCellsStatement := FALSE;
x.Accept(SELF);
resolved := resolvedStatement;
resolvedStatement := prev;
RETURN resolved
END ResolveStatement;
PROCEDURE StatementSequence(statementSequence: SyntaxTree.StatementSequence);
VAR i: LONGINT; statement,resolved: SyntaxTree.Statement;
BEGIN
IF statementSequence # NIL THEN
FOR i := 0 TO statementSequence.Length()-1 DO
statement := statementSequence.GetStatement(i);
resolved := ResolveStatement(statement);
IF (resolved # statement) THEN
statementSequence.SetStatement(i,resolved);
END;
END;
END;
END StatementSequence;
PROCEDURE VisitProcedureCallStatement(procedureCall: SyntaxTree.ProcedureCallStatement);
VAR call: SyntaxTree.Designator;
BEGIN
IF Trace THEN D.Str("VisitProcedureCallStatement"); D.Ln; END;
call := procedureCall.call;
IF (call # NIL) & ~(call IS SyntaxTree.ParameterDesignator) & ~(call IS SyntaxTree.ProcedureCallDesignator) & ~(call IS SyntaxTree.BuiltinCallDesignator) THEN
call := SyntaxTree.NewParameterDesignator(call.position,call,SyntaxTree.NewExpressionList());
END;
call := ResolveDesignator(call);
IF call = SyntaxTree.invalidDesignator THEN
ELSIF ~IsCallable(call) THEN
Error(procedureCall.position,Diagnostics.Invalid,"called object is not a procedure");
ELSIF (call.type # NIL) & (call.left # NIL) & (call.left.type.resolved(SyntaxTree.ProcedureType).callingConvention # SyntaxTree.WinAPICallingConvention) THEN
Error(procedureCall.position,Diagnostics.Invalid,"calling procedure with non-void return type");
IF VerboseErrorMessage THEN Printout.Info("call ",call) END;
END;
procedureCall.SetCall(call);
END VisitProcedureCallStatement;
PROCEDURE VisitAssignment(assignment: SyntaxTree.Assignment);
VAR
left: SyntaxTree.Designator;
right, expression: SyntaxTree.Expression;
designator: SyntaxTree.Designator;
procedureCallDesignator: SyntaxTree.ProcedureCallDesignator;
type: SyntaxTree.Type;
procedureType: SyntaxTree.ProcedureType;
mathArrayType: SyntaxTree.MathArrayType;
dimensionality: LONGINT;
BEGIN
right := ResolveExpression(assignment.right);
assignment.left.SetRelatedRhs(right);
left := ResolveDesignator(assignment.left);
IF (left = SyntaxTree.invalidDesignator) OR (right = SyntaxTree.invalidExpression) THEN
ELSIF (left IS SyntaxTree.ProcedureCallDesignator) & (left.type = NIL) & (left.relatedAsot # NIL) THEN
procedureCallDesignator := left(SyntaxTree.ProcedureCallDesignator);
resolvedStatement := SyntaxTree.NewProcedureCallStatement(assignment.position, procedureCallDesignator, assignment.outer);
ELSIF CheckVariable(left) THEN
expression := NewOperatorCall(assignment.position, Scanner.Becomes, left, right, NIL);
IF (expression # NIL) & (expression IS SyntaxTree.ProcedureCallDesignator) THEN
procedureCallDesignator := expression(SyntaxTree.ProcedureCallDesignator);
resolvedStatement := SyntaxTree.NewProcedureCallStatement(assignment.position, procedureCallDesignator, assignment.outer);
ELSIF AssignmentCompatible(left, right) THEN
IF IsArrayStructuredObjectType(left.type) & (left.type.resolved # right.type.resolved) THEN
mathArrayType := MathArrayStructureOfType(left.type);
right := NewConversion(right.position, right, mathArrayType, NIL);
designator := NewIndexOperatorCall(InvalidPosition, left, ListOfOpenRanges(mathArrayType.Dimensionality()), right);
resolvedStatement := SyntaxTree.NewProcedureCallStatement(assignment.position, designator, assignment.outer)
ELSE
right := NewConversion(right.position, right, left.type.resolved, NIL);
assignment.SetLeft(left);
assignment.SetRight(right);
resolvedStatement := assignment
END
END
END
END VisitAssignment;
PROCEDURE IfPart(ifPart: SyntaxTree.IfPart; VAR true: BOOLEAN);
VAR prevUnreachable, b: BOOLEAN;
BEGIN
prevUnreachable := currentIsUnreachable;
ifPart.SetCondition(ResolveCondition(ifPart.condition));
IF IsBooleanValue(ifPart.condition,b) THEN
IF b=FALSE THEN
currentIsUnreachable := TRUE
ELSIF b=TRUE THEN
true := TRUE
END;
END;
StatementSequence(ifPart.statements);
currentIsUnreachable := prevUnreachable;
END IfPart;
PROCEDURE VisitIfStatement(ifStatement: SyntaxTree.IfStatement);
VAR elsif: SyntaxTree.IfPart; i: LONGINT; ifPartTrue, prevUnreachable: BOOLEAN;
BEGIN
prevUnreachable := currentIsUnreachable;
ifPartTrue := FALSE;
IfPart(ifStatement.ifPart,ifPartTrue);
FOR i := 0 TO ifStatement.ElsifParts()-1 DO
elsif := ifStatement.GetElsifPart(i);
IfPart(elsif,ifPartTrue);
END;
IF ifStatement.elsePart # NIL THEN
IF ifPartTrue THEN
currentIsUnreachable := TRUE
END;
StatementSequence(ifStatement.elsePart)
END;
currentIsUnreachable := prevUnreachable;
END VisitIfStatement;
PROCEDURE WithPart(withPart: SyntaxTree.WithPart; VAR symbol: SyntaxTree.Symbol);
VAR variable,typeDesignator: SyntaxTree.Designator;
type,variableType: SyntaxTree.Type;
prevScope : SyntaxTree.Scope;
withEntry: WithEntry;
typeDeclaration: SyntaxTree.TypeDeclaration;
BEGIN
variable := ResolveDesignator(withPart.variable);
variableType := variable.type.resolved;
withPart.SetVariable(variable);
type := ResolveType(withPart.type);
withPart.SetType(type);
WHILE variable IS SyntaxTree.TypeGuardDesignator DO
variable := variable(SyntaxTree.TypeGuardDesignator).left(SyntaxTree.Designator);
END;
IF (type.resolved = SyntaxTree.invalidType) OR (variableType = SyntaxTree.invalidType) THEN
ELSIF ~(type.resolved = variableType) & ~IsExtensibleDesignator(variable) THEN
Error(variable.position,Diagnostics.Invalid,"is not extensible designator");
ELSIF ~(variable IS SyntaxTree.SymbolDesignator) THEN
Error(variable.position,Diagnostics.Invalid,"is no local variable ");
IF VerboseErrorMessage THEN
Printout.Info("variable",variable)
END;
ELSIF ~IsTypeExtension(variableType, type.resolved) THEN
Error(variable.position,Diagnostics.Invalid,"withguarded symbol is no type extension of ");
IF VerboseErrorMessage THEN
Printout.Info("variable",variable);
Printout.Info("type",type);
END;
ELSIF ~(variable(SyntaxTree.SymbolDesignator).symbol IS SyntaxTree.Variable)
& ~(variable(SyntaxTree.SymbolDesignator).symbol IS SyntaxTree.Parameter) THEN
Error(variable.position,Diagnostics.Invalid,"withguarded symbol is no variable ");
IF VerboseErrorMessage THEN
Printout.Info("variable",variable);
Printout.Info("type",type);
END;
ELSIF (symbol # NIL) & (symbol # variable(SyntaxTree.SymbolDesignator).symbol) THEN
Error(variable.position,Diagnostics.Invalid,"invalid change of withguarded symbol");
ELSE
symbol := variable(SyntaxTree.SymbolDesignator).symbol;
NEW(withEntry);
withEntry.previous := withEntries;
withEntry.symbol := variable(SyntaxTree.SymbolDesignator).symbol;
withEntry.type := type;
withEntries := withEntry;
StatementSequence(withPart.statements);
withEntries := withEntries.previous;
END;
END WithPart;
PROCEDURE VisitWithStatement(withStatement: SyntaxTree.WithStatement);
VAR i: LONGINT; prevScope: SyntaxTree.Scope; symbol: SyntaxTree.Symbol;
BEGIN
prevScope := currentScope; symbol := NIL;
FOR i := 0 TO withStatement.WithParts()-1 DO
WithPart(withStatement.GetWithPart(i),symbol);
END;
IF withStatement.elsePart # NIL THEN
StatementSequence(withStatement.elsePart)
END;
currentScope := prevScope;
END VisitWithStatement;
PROCEDURE CasePart(casePart: SyntaxTree.CasePart; type: SyntaxTree.Type; VAR allcases: SyntaxTree.CaseConstant; VAR min,max: LONGINT);
VAR
i: LONGINT;
position: LONGINT;
expression, left, right: SyntaxTree.Expression;
expressionType: SyntaxTree.Type;
l, r: LONGINT;
cl, cr: CHAR;
thiscases: SyntaxTree.CaseConstant;
BEGIN
thiscases := NIL;
FOR i := 0 TO casePart.elements.Length() - 1 DO
expression := casePart.elements.GetExpression(i);
position := expression.position;
IF expression IS SyntaxTree.RangeExpression THEN
expression(SyntaxTree.RangeExpression).SetContext(SyntaxTree.CaseGuard)
END;
expression := ResolveExpression(expression);
IF expression = SyntaxTree.invalidExpression THEN
expressionType := SyntaxTree.invalidType;
ELSIF (expression IS SyntaxTree.RangeExpression) THEN
left := expression(SyntaxTree.RangeExpression).first;
right := expression(SyntaxTree.RangeExpression).last;
ASSERT((left # NIL) & (right # NIL));
ASSERT(left.type.resolved = right.type.resolved);
left := CompatibleConversion(left.position, left, type);
right := CompatibleConversion(right.position, right, type);
expression(SyntaxTree.RangeExpression).SetFirst(left);
expression(SyntaxTree.RangeExpression).SetLast(right);
expressionType := RegularType(position,left.type);
ELSE
expression := ConstantExpression(expression);
expression := CompatibleConversion(expression.position, expression, type);
casePart.elements.SetExpression(i,expression);
left := expression; right := expression;
expressionType := RegularType(position,expression.type)
END;
IF (expressionType = SyntaxTree.invalidType) THEN
ELSIF ~CompatibleTo(system,expressionType,type) THEN
Error(position,Diagnostics.Invalid,"inadmissible case label");
expression := SyntaxTree.invalidExpression;
ELSE
l := 0; r := 0;
IF IsIntegerValue(left,l) & CheckIntegerValue(right,r) THEN
ELSIF IsCharacterValue(left,cl) & CheckCharacterValue(right,cr) THEN
l := ORD(cl); r := ORD(cr);
ELSIF IsEnumerationValue(left,l) & CheckEnumerationValue(right,r) THEN
ELSE
expression := SyntaxTree.invalidExpression
END;
IF expression # SyntaxTree.invalidExpression THEN
IF l>r THEN
Error(position,Diagnostics.Invalid,"empty case label")
ELSIF ~EnterCase(thiscases,l,r) OR ~EnterCase(allcases,l,r) THEN
Error(position,Diagnostics.Invalid,"duplicate case label");
ELSE
IF l < min THEN min := l END;
IF r > max THEN max := r END;
END;
END;
END;
casePart.elements.SetExpression(i,expression);
END;
casePart.SetConstants(thiscases);
StatementSequence(casePart.statements);
END CasePart;
PROCEDURE VisitCaseStatement(caseStatement: SyntaxTree.CaseStatement);
VAR expression: SyntaxTree.Expression; i: LONGINT; type: SyntaxTree.Type; caseList: SyntaxTree.CaseConstant;
ch: CHAR; l: LONGINT; min,max: LONGINT; msg: ARRAY 64 OF CHAR;
BEGIN
expression := ResolveExpression(caseStatement.variable);
type := RegularType(expression.position,expression.type);
IF type = SyntaxTree.invalidType THEN
expression := SyntaxTree.invalidExpression;
ELSIF IsIntegerType(type) THEN
ELSIF IsStringType(expression.type) THEN
expression := NewConversion(expression.position, expression, system.characterType,NIL);
type := expression.type;
ELSIF IsCharacterType(type) THEN
ELSIF IsEnumerationType(type) THEN
ELSE
Error(caseStatement.variable.position,Diagnostics.Invalid,"variable must be integer or character type");
expression := SyntaxTree.invalidExpression;
END;
caseStatement.SetVariable(expression);
caseList := NIL;
min := MAX(LONGINT); max := MIN(LONGINT);
FOR i := 0 TO caseStatement.CaseParts()-1 DO
CasePart(caseStatement.GetCasePart(i),type,caseList,min,max);
END;
IF (max - min > 1024) & (100* caseStatement.CaseParts() DIV (max-min) < 10) THEN
msg := "huge sparse case table ";
Strings.AppendInt(msg, max-min);
Strings.Append(msg,"/");
Strings.AppendInt(msg, caseStatement.CaseParts());
Warning(caseStatement.position,msg);
END;
caseStatement.SetMinMax(min,max);
StatementSequence(caseStatement.elsePart);
IF expression.resolved # NIL THEN
IF IsCharacterValue(expression,ch) THEN
l := ORD(ch)
ELSIF IsIntegerValue(expression,l) THEN
END;
IF EnterCase(caseList,l,l) & (caseStatement.elsePart = NIL) THEN Error(caseStatement.position,Diagnostics.Invalid,"no matching case label") END;
END;
END VisitCaseStatement;
PROCEDURE VisitWhileStatement(whileStatement: SyntaxTree.WhileStatement);
VAR prevIsUnreachable,b: BOOLEAN;
BEGIN
prevIsUnreachable := currentIsUnreachable;
whileStatement.SetCondition(ResolveCondition(whileStatement.condition));
IF IsBooleanValue(whileStatement.condition,b) THEN
IF b=FALSE THEN
currentIsUnreachable := TRUE
END;
END;
StatementSequence(whileStatement.statements);
currentIsUnreachable := prevIsUnreachable
END VisitWhileStatement;
PROCEDURE VisitRepeatStatement(repeatStatement: SyntaxTree.RepeatStatement);
BEGIN
repeatStatement.SetCondition(ResolveCondition(repeatStatement.condition));
StatementSequence(repeatStatement.statements);
END VisitRepeatStatement;
PROCEDURE GetGuard(symbol: SyntaxTree.Symbol; VAR type: SyntaxTree.Type): BOOLEAN;
VAR withEntry: WithEntry;
BEGIN
withEntry := withEntries;
WHILE (withEntry # NIL) & (withEntry.symbol # symbol) DO
withEntry := withEntry.previous
END;
IF withEntry = NIL THEN RETURN FALSE
ELSE
type := withEntry.type;
RETURN TRUE
END;
END GetGuard;
PROCEDURE VisitForStatement(forStatement: SyntaxTree.ForStatement);
VAR expression: SyntaxTree.Expression; designator: SyntaxTree.Designator; type: SyntaxTree.Type;
BEGIN
designator := ResolveDesignator(forStatement.variable);
type := SyntaxTree.invalidType;
IF designator.type = SyntaxTree.invalidType THEN
designator := SyntaxTree.invalidDesignator;
ELSIF ~IsIntegerType(designator.type.resolved) THEN
Error(designator.position,Diagnostics.Invalid,"control variable of non-integer type");
designator := SyntaxTree.invalidDesignator;
ELSIF CheckVariable(designator) THEN
type := designator.type;
END;
forStatement.SetVariable(designator);
expression := ResolveExpression(forStatement.from);
IF expression = SyntaxTree.invalidExpression THEN
ELSIF ~CompatibleTo(system,expression.type.resolved,designator.type.resolved) THEN
Error(expression.position,Diagnostics.Invalid,"start value of incompatible type");
expression := SyntaxTree.invalidExpression;
ELSIF type # SyntaxTree.invalidType THEN
expression := NewConversion(expression.position,expression,type,NIL)
END;
forStatement.SetFrom(expression);
expression := ResolveExpression(forStatement.to);
IF expression = SyntaxTree.invalidExpression THEN
ELSIF ~CompatibleTo(system,expression.type.resolved,designator.type.resolved) THEN
Error(expression.position,Diagnostics.Invalid,"end value of incompatible type");
expression := SyntaxTree.invalidExpression;
ELSIF type # SyntaxTree.invalidType THEN
expression := NewConversion(expression.position,expression,type,NIL)
END;
forStatement.SetTo(expression);
IF forStatement.by # NIL THEN
expression := ConstantInteger(forStatement.by);
ELSE
expression := Global.NewIntegerValue(system,InvalidPosition,1);
END;
IF expression = SyntaxTree.invalidExpression THEN
ELSIF ~CompatibleTo(system,expression.type.resolved,designator.type.resolved) THEN
Error(expression.position,Diagnostics.Invalid,"step value of incompatible type");
ELSIF (expression.resolved(SyntaxTree.IntegerValue).hvalue = 0) THEN
Error(expression.position,Diagnostics.Invalid,"invalid step value");
ELSIF type # SyntaxTree.invalidType THEN
expression := NewConversion(expression.position,expression,type,NIL)
END;
forStatement.SetBy(expression);
StatementSequence(forStatement.statements);
END VisitForStatement;
PROCEDURE VisitLoopStatement(loopStatement: SyntaxTree.LoopStatement);
BEGIN
StatementSequence(loopStatement.statements)
END VisitLoopStatement;
PROCEDURE VisitExitStatement(exitStatement: SyntaxTree.ExitStatement);
VAR outer: SyntaxTree.Statement;
BEGIN
outer := exitStatement.outer;
WHILE(outer # NIL) & ~(outer IS SyntaxTree.LoopStatement) DO
outer := outer.outer;
END;
IF outer = NIL THEN
Error(exitStatement.position,Diagnostics.Invalid,"exit statement not within loop statement");
END;
END VisitExitStatement;
PROCEDURE VisitReturnStatement(returnStatement: SyntaxTree.ReturnStatement);
VAR expression: SyntaxTree.Expression; position: LONGINT; procedure: SyntaxTree.Procedure;
returnType: SyntaxTree.Type; outer: SyntaxTree.Statement; scope: SyntaxTree.Scope;
BEGIN
position := returnStatement.position;
expression := returnStatement.returnValue;
IF expression # NIL THEN
expression := ResolveExpression(expression);
returnStatement.SetReturnValue(expression);
END;
outer := returnStatement.outer;
WHILE(outer # NIL) & ~(outer IS SyntaxTree.Body) DO
outer := outer.outer
END;
IF (outer # NIL) THEN
scope := outer(SyntaxTree.Body).inScope;
IF ~(scope IS SyntaxTree.ProcedureScope) THEN
IF (expression # NIL) THEN
Error(position,Diagnostics.Invalid,"return statement with parameter not in procedure scope");
END;
ELSE
procedure := scope(SyntaxTree.ProcedureScope).ownerProcedure;
returnType := procedure.type(SyntaxTree.ProcedureType).returnType;
IF returnType # NIL THEN
returnType := returnType.resolved;
IF expression = NIL THEN
Error(position,Diagnostics.Invalid,"empty return type in procedure providing a return type")
ELSIF expression.type = NIL THEN
Error(position, Diagnostics.Invalid,"returned type incompatible: expression has no type");
ELSIF ~CompatibleTo(system,expression.type.resolved,returnType) THEN
Error(position,Diagnostics.Invalid,"return type not compatible");
IF VerboseErrorMessage THEN
Printout.Info("returnType",returnType);
Printout.Info("expression",expression);
END;
ELSE
expression := NewConversion(expression.position,expression,returnType,NIL);
returnStatement.SetReturnValue(expression);
END;
ELSIF expression # NIL THEN
Error(position,Diagnostics.Invalid,"non-empty return type in procedure providing no return type");
END;
END;
END;
END VisitReturnStatement;
PROCEDURE VisitAwaitStatement(awaitStatement: SyntaxTree.AwaitStatement);
VAR condition: SyntaxTree.Expression;
BEGIN
condition := ResolveCondition(awaitStatement.condition);
IF currentIsRealtime THEN
Error(awaitStatement.position,Diagnostics.Invalid,"forbidden await statement in realtime block");
END;
IF (condition.resolved # NIL) & (condition.resolved IS SyntaxTree.BooleanValue) THEN
Error(awaitStatement.position,Diagnostics.Invalid,"senseless await statement with constant condition");
END;
awaitStatement.SetCondition(condition);
END VisitAwaitStatement;
PROCEDURE VisitCode(code: SyntaxTree.Code);
BEGIN
END VisitCode;
PROCEDURE BlockFlags(block: SyntaxTree.StatementBlock);
VAR blockModifier: SyntaxTree.Modifier; expression: SyntaxTree.Expression; name: SyntaxTree.Identifier; flags: SET; position: LONGINT;
forbidden: SET; flag: LONGINT; recordBody: SyntaxTree.Body;
PROCEDURE SetProtectedRecord;
VAR scope: SyntaxTree.Scope;
BEGIN
scope := currentScope;
WHILE (scope # NIL) & ~(scope IS SyntaxTree.RecordScope) DO
scope := scope.outerScope
END;
IF scope # NIL THEN
scope(SyntaxTree.RecordScope).ownerRecord.SetProtected(TRUE);
END;
END SetProtectedRecord;
BEGIN
flags := {};
IF (block IS SyntaxTree.Body) & (currentIsBodyProcedure) & ((currentScope.outerScope = NIL) OR ~(currentScope.outerScope IS SyntaxTree.ModuleScope)) THEN
recordBody := block(SyntaxTree.Body)
ELSE
recordBody := NIL
END;
blockModifier := block.blockModifiers;
WHILE(blockModifier # NIL) DO
name := blockModifier.identifier;
expression := blockModifier.expression;
position := blockModifier.position;
flag := -1;
IF name=Global.NamePriority THEN
IF expression = NIL THEN
Error(position,Diagnostics.Invalid,"missing priority expression");
ELSIF recordBody = NIL THEN
Error(position,Diagnostics.Invalid,"priority not on record body");
ELSIF recordBody.priority # NIL THEN
Error(position,Diagnostics.Invalid,"duplicate priority expression");
ELSE
recordBody.SetPriority(expression);
END;
ELSIF expression # NIL THEN
Error(expression.position,Diagnostics.Invalid,"expression not in connection with priority")
ELSIF name=Global.NameExclusive THEN
IF block.isExclusive THEN
Error(position,Diagnostics.Invalid,"duplicate exclusive flag")
END;
block.SetExclusive(TRUE); SetProtectedRecord;
ELSIF name=Global.NameActive THEN
IF recordBody = NIL THEN
Error(position,Diagnostics.Invalid,"active not in record body");
ELSIF recordBody.isActive THEN
Error(position,Diagnostics.Invalid,"duplicate active flag")
ELSE
recordBody.SetActive(TRUE); SetProtectedRecord;
END;
ELSIF name=Global.NameSafe THEN
IF recordBody = NIL THEN
Error(position,Diagnostics.Invalid,"safe not in record body");
ELSIF recordBody.isSafe THEN
Error(position,Diagnostics.Invalid,"duplicate safe flag")
ELSE
recordBody.SetSafe(TRUE);
SetProtectedRecord;
END;
ELSIF name=Global.NameRealtime THEN
IF recordBody = NIL THEN
Error(position,Diagnostics.Invalid,"realtime not in record body");
ELSIF recordBody.isRealtime THEN
Error(position,Diagnostics.Invalid,"duplicate realtime flag")
ELSE
recordBody.SetRealtime(TRUE);
block.SetRealtime(TRUE);
END;
ELSE
Error(position,Diagnostics.Invalid,"unknown block modifier");
END;
blockModifier := blockModifier.nextModifier;
END;
END BlockFlags;
PROCEDURE VisitStatementBlock(statementBlock: SyntaxTree.StatementBlock);
VAR recentExclusive, recentUnreachable, recentRealtime: BOOLEAN;
BEGIN
BlockFlags(statementBlock);
IF statementBlock.isExclusive THEN
IF currentIsExclusive THEN
Error (statementBlock.position,Diagnostics.Invalid,"forbidden recursive exclusive")
ELSIF currentIsRealtime THEN
Error( statementBlock.position,Diagnostics.Invalid,"forbidden exculsive in realtime block");
END;
END;
recentExclusive := currentIsExclusive;
recentUnreachable := currentIsUnreachable;
recentRealtime := currentIsRealtime;
IF statementBlock.isExclusive THEN currentIsExclusive := TRUE END;
IF statementBlock.isUnreachable THEN currentIsUnreachable := TRUE END;
IF statementBlock.isRealtime THEN currentIsRealtime := TRUE END;
StatementSequence(statementBlock.statements);
currentIsRealtime := recentRealtime;
currentIsExclusive := recentExclusive;
currentIsUnreachable := recentUnreachable;
END VisitStatementBlock;
PROCEDURE Body(body: SyntaxTree.Body);
BEGIN
VisitStatementBlock(body);
IF body.isActive THEN
IF ~currentIsBodyProcedure THEN
Error(body.position,Diagnostics.Invalid,"active flag not in object body");
ELSIF body.priority # NIL THEN
body.SetPriority(ConstantInteger(body.priority));
END;
ELSIF body.isSafe THEN
Error(body.position,Diagnostics.Invalid,"safe flag not in active body");
ELSIF body.priority # NIL THEN
Error(body.position,Diagnostics.Invalid,"priority flag not in active body");
END;
StatementSequence(body.finally)
END Body;
PROCEDURE Register(symbol: SyntaxTree.Symbol; scope: SyntaxTree.Scope; allowDuplicate: BOOLEAN);
VAR duplicateSymbol: BOOLEAN;
BEGIN
ASSERT(symbol.name # SyntaxTree.invalidIdentifier);
IF ~allowDuplicate & (global.FindSymbol(symbol.name)#NIL) THEN
Error(symbol.position,Diagnostics.Invalid,"globally defined keyword")
END;
scope.EnterSymbol(symbol,duplicateSymbol);
IF ~allowDuplicate & duplicateSymbol THEN
Error(symbol.position,Basic.MultiplyDefinedIdentifier,"");
IF VerboseErrorMessage THEN
Printout.Info("multiply defined identifier",symbol);
Printout.Info("in scope",scope);
END;
END;
END Register;
PROCEDURE Implementation(scope: SyntaxTree.Scope);
VAR prevScope: SyntaxTree.Scope; procedure: SyntaxTree.Procedure; prevIsRealtime, prevIsBodyProcedure, prevIsCellNet: BOOLEAN;
BEGIN
prevIsRealtime := currentIsRealtime;
prevIsBodyProcedure := currentIsBodyProcedure;
prevIsCellNet := currentIsCellNet;
prevScope := currentScope;
currentScope := scope;
IF (scope IS SyntaxTree.ProcedureScope) THEN
procedure := scope(SyntaxTree.ProcedureScope).ownerProcedure;
currentIsBodyProcedure := currentIsBodyProcedure OR procedure.isBodyProcedure;
currentIsRealtime := currentIsRealtime OR procedure.type.isRealtime;
IF (procedure.scope # NIL) &
((procedure.scope IS SyntaxTree.ModuleScope)
& (procedure.scope(SyntaxTree.ModuleScope).bodyProcedure = procedure)
& (procedure.scope(SyntaxTree.ModuleScope).ownerModule.isCellNet)
OR
(procedure.scope IS SyntaxTree.CellScope)
& (procedure.scope(SyntaxTree.CellScope).bodyProcedure = procedure)
& (procedure.scope(SyntaxTree.CellScope).ownerCell.isCellNet)
)
THEN
currentIsCellNet := TRUE
END;
IF procedure.isInline & ((scope(SyntaxTree.ProcedureScope).body = NIL) OR (scope(SyntaxTree.ProcedureScope).body # NIL) & (scope(SyntaxTree.ProcedureScope).body.code = NIL)) THEN
Error(procedure.position,Diagnostics.Invalid,"unsupported inline procedure - must be assembler code")
END;
END;
IF (scope IS SyntaxTree.ProcedureScope) & (scope(SyntaxTree.ProcedureScope).body # NIL) THEN
Body(scope(SyntaxTree.ProcedureScope).body)
END;
currentScope := prevScope;
currentIsRealtime := prevIsRealtime;
currentIsBodyProcedure := prevIsBodyProcedure;
currentIsCellNet := prevIsCellNet;
END Implementation;
PROCEDURE Implementations(x: SyntaxTree.Module);
VAR scope: SyntaxTree.Scope; prevPhase: LONGINT;
BEGIN
prevPhase := phase;
phase := ImplementationPhase;
scope := x.firstScope;
WHILE(scope # NIL) DO
Implementation(scope);
scope := scope.nextScope;
END;
phase := prevPhase;
END Implementations;
PROCEDURE Declarations(scope: SyntaxTree.Scope);
VAR
constant: SyntaxTree.Constant;
typeDeclaration: SyntaxTree.TypeDeclaration;
variable: SyntaxTree.Variable;
procedure: SyntaxTree.Procedure;
prevScope: SyntaxTree.Scope;
parameter: SyntaxTree.Parameter;
import: SyntaxTree.Import;
symbol: SyntaxTree.Symbol;
prevPhase: LONGINT;
BEGIN
prevPhase := phase;
phase := DeclarationPhase;
prevScope := currentScope;
currentScope := scope;
IF scope IS SyntaxTree.ModuleScope THEN
import := scope(SyntaxTree.ModuleScope).firstImport;
WHILE(import # NIL) DO
IF import.context = SyntaxTree.invalidIdentifier THEN import.SetContext(scope.ownerModule.context) END;
Register(import, currentScope, FALSE);
import := import.nextImport;
END;
import := scope(SyntaxTree.ModuleScope).firstImport;
WHILE(import # NIL) DO
ResolveSymbol(import);
import := import.nextImport;
END;
ELSIF scope IS SyntaxTree.ProcedureScope THEN
parameter := scope(SyntaxTree.ProcedureScope).ownerProcedure.type.resolved(SyntaxTree.ProcedureType).firstParameter;
WHILE(parameter # NIL) DO
Register(parameter,currentScope, FALSE); parameter := parameter.nextParameter;
END;
parameter := scope(SyntaxTree.ProcedureScope).ownerProcedure.type.resolved(SyntaxTree.ProcedureType).returnParameter;
IF parameter # NIL THEN Register(parameter, currentScope, FALSE); END;
ELSIF scope IS SyntaxTree.CellScope THEN
parameter := scope(SyntaxTree.CellScope).ownerCell.firstParameter;
WHILE(parameter # NIL) DO
Register(parameter,scope, FALSE); parameter := parameter.nextParameter;
END;
END;
IF error THEN RETURN END;
constant := scope.firstConstant;
WHILE (constant # NIL) DO
Register(constant, currentScope, FALSE); constant := constant.nextConstant;
END;
typeDeclaration := scope.firstTypeDeclaration;
WHILE (typeDeclaration # NIL) DO
Register(typeDeclaration, currentScope, FALSE); typeDeclaration := typeDeclaration.nextTypeDeclaration;
END;
variable := scope.firstVariable;
WHILE (variable # NIL) DO
Register(variable, currentScope, FALSE); variable := variable.nextVariable;
END;
procedure := scope.firstProcedure;
WHILE (procedure # NIL) DO
Register(procedure, currentScope, procedure IS SyntaxTree.Operator); procedure := procedure.nextProcedure;
END;
symbol := scope.firstSymbol;
WHILE(symbol # NIL) DO
IF ~(symbol IS SyntaxTree.Parameter) OR (symbol(SyntaxTree.Parameter).ownerType IS SyntaxTree.CellType) THEN
ResolveSymbol(symbol);
END;
symbol := symbol.nextSymbol;
END;
IF (scope IS SyntaxTree.ProcedureScope) & scope(SyntaxTree.ProcedureScope).ownerProcedure.type.isRealtime THEN
symbol := scope.firstSymbol;
WHILE symbol # NIL DO
IF (symbol IS SyntaxTree.Variable) OR (symbol IS SyntaxTree.Parameter) THEN
IF (symbol.type IS SyntaxTree.PointerType) OR (symbol.type IS SyntaxTree.QualifiedType) THEN
pointerFixes.Add(symbol, currentScope);
END;
IF ~symbol.type.resolved.isRealtime THEN
Error(symbol.position,Diagnostics.Invalid,"symbol has no realtime type");
END;
END;
symbol := symbol.nextSymbol
END;
END;
IF ~error & ~system.GenerateVariableOffsets(scope) THEN
Error(Diagnostics.Invalid,Diagnostics.Invalid,"problems during offset computation in module");
END;
IF scope.ownerModule # NIL THEN
scope.ownerModule.AddScope(scope);
END;
phase := prevPhase;
currentScope := prevScope;
END Declarations;
PROCEDURE CheckInterOperatorConformity(thisModuleScope, thatModuleScope: SyntaxTree.ModuleScope);
VAR
thisOperator, thatOperator: SyntaxTree.Operator;
thisProcedureType, thatProcedureType: SyntaxTree.ProcedureType;
thisParameter, thatParameter: SyntaxTree.Parameter;
operandsAreEqual, operandsAreCompatible, hasError: BOOLEAN;
i: LONGINT;
BEGIN
currentScope := thisModuleScope;
hasError := FALSE;
thatOperator := thatModuleScope.firstOperator;
WHILE (thatOperator # NIL) & ~hasError DO
IF (thisModuleScope = thatModuleScope) OR (SyntaxTree.PublicRead IN thatOperator.access) THEN
IF thatOperator.name # Global.GetIdentifier(Global.Conversion, thatModuleScope.ownerModule.case) THEN
thisOperator := thisModuleScope.firstOperator;
WHILE (thisOperator # NIL) & ~hasError DO
IF thisOperator # thatOperator THEN
IF thisOperator.name = thatOperator.name THEN
ASSERT(thisOperator.type IS SyntaxTree.ProcedureType);
ASSERT(thatOperator.type IS SyntaxTree.ProcedureType);
thisProcedureType := thisOperator.type(SyntaxTree.ProcedureType);
thatProcedureType := thatOperator.type(SyntaxTree.ProcedureType);
IF thisProcedureType.numberParameters = thatProcedureType.numberParameters THEN
thisParameter := thisProcedureType.firstParameter;
thatParameter := thatProcedureType.firstParameter;
operandsAreEqual := TRUE;
operandsAreCompatible := TRUE;
FOR i := 1 TO thisProcedureType.numberParameters DO
ASSERT(thatParameter # NIL);
IF ~SameType(thisParameter.type, thatParameter.type) THEN
operandsAreEqual := FALSE;
IF ~CompatibleTo(system, thisParameter.type, thatParameter.type) THEN
operandsAreCompatible := FALSE
END
END;
thisParameter := thisParameter.nextParameter;
thatParameter := thatParameter.nextParameter
END;
IF operandsAreEqual THEN
Error(thisOperator.position, Diagnostics.Invalid, "operator has the same identifier and operand types as other one");
hasError := TRUE
ELSIF operandsAreCompatible THEN
IF ~CompatibleTo(system, thisProcedureType.returnType, thatProcedureType.returnType) THEN
Error(thisOperator.position, Diagnostics.Invalid, "operator's return type is not compatible to the one of a more generic operator");
hasError := TRUE
ELSIF ~thisOperator.isDynamic & thatOperator.isDynamic THEN
Error(thisOperator.position, Diagnostics.Invalid, "operator must be dynamic because it is signature-compatible to a dynamic one");
hasError := TRUE
END
END
END
END
END;
thisOperator := thisOperator.nextOperator
END
END
END;
thatOperator := thatOperator.nextOperator
END
END CheckInterOperatorConformity;
PROCEDURE Module*(x: SyntaxTree.Module);
VAR
import: SyntaxTree.Import; modifier: SyntaxTree.Modifier; value,position: LONGINT;
BEGIN
module := x;
ASSERT(x # NIL);
global := system.globalScope[x.case];
x.moduleScope.SetGlobalScope(global);
IF (x.name = Global.SystemName) OR (x.name = Global.systemName) THEN Error(x.position,Diagnostics.Invalid,"name reserved") END;
IF x.context = SyntaxTree.invalidIdentifier THEN x.SetContext(Global.A2Name) END;
RemoveModuleFromCache(importCache,x);
Declarations(x.moduleScope);
FixTypes();
IF module.isCellNet THEN
modifier := x.modifiers;
IF HasValue(modifier,Global.NameFrequencyDivider,position,value) THEN END;
CheckModifiers(modifier);
END;
IF ~error THEN
CheckInterOperatorConformity(x.moduleScope, x.moduleScope);
import := x.moduleScope.firstImport;
WHILE import # NIL DO
IF (import.module # NIL) & ~Global.IsSystemModule(import.module) THEN
CheckInterOperatorConformity(x.moduleScope, import.module.moduleScope)
END;
import := import.nextImport
END;
END;
Implementations(x);
module := NIL;
END Module;
END Checker;
Warnings*=OBJECT (SyntaxTree.Visitor)
VAR diagnostics: Diagnostics.Diagnostics; module: SyntaxTree.Module;
PROCEDURE &InitWarnings*(diagnostics: Diagnostics.Diagnostics);
BEGIN
SELF.diagnostics := diagnostics
END InitWarnings;
PROCEDURE Type(x: SyntaxTree.Type);
BEGIN x.Accept(SELF)
END Type;
PROCEDURE VisitType*(x: SyntaxTree.Type);
BEGIN END VisitType;
PROCEDURE VisitBasicType*(x: SyntaxTree.BasicType);
BEGIN END VisitBasicType;
PROCEDURE VisitCharacterType*(x: SyntaxTree.CharacterType);
BEGIN END VisitCharacterType;
PROCEDURE VisitIntegerType*(x: SyntaxTree.IntegerType);
BEGIN END VisitIntegerType;
PROCEDURE VisitFloatType*(x: SyntaxTree.FloatType);
BEGIN END VisitFloatType;
PROCEDURE VisitQualifiedType*(x: SyntaxTree.QualifiedType);
BEGIN END VisitQualifiedType;
PROCEDURE VisitStringType*(x: SyntaxTree.StringType);
BEGIN END VisitStringType;
PROCEDURE VisitEnumerationType*(x: SyntaxTree.EnumerationType);
BEGIN END VisitEnumerationType;
PROCEDURE VisitRangeType*(x: SyntaxTree.RangeType);
BEGIN END VisitRangeType;
PROCEDURE VisitArrayType*(x: SyntaxTree.ArrayType);
BEGIN
IF ~(SyntaxTree.Warned IN x.state) THEN
x.SetState(SyntaxTree.Warned);
Type(x.arrayBase);
END;
END VisitArrayType;
PROCEDURE VisitMathArrayType*(x: SyntaxTree.MathArrayType);
BEGIN
IF ~(SyntaxTree.Warned IN x.state) THEN
x.SetState(SyntaxTree.Warned);
Type(x.arrayBase);
END;
END VisitMathArrayType;
PROCEDURE VisitPointerType*(x: SyntaxTree.PointerType);
BEGIN
IF ~(SyntaxTree.Warned IN x.state) THEN
x.SetState(SyntaxTree.Warned);
Type(x.pointerBase);
END;
END VisitPointerType;
PROCEDURE VisitRecordType*(x: SyntaxTree.RecordType);
BEGIN Scope(x.recordScope) END VisitRecordType;
PROCEDURE VisitCellType*(x: SyntaxTree.CellType);
BEGIN Scope(x.cellScope) END VisitCellType;
PROCEDURE VisitProcedureType*(x: SyntaxTree.ProcedureType);
BEGIN END VisitProcedureType;
PROCEDURE Warning(x: SyntaxTree.Symbol; CONST text: ARRAY OF CHAR);
VAR msg: ARRAY 256 OF CHAR;
BEGIN
Global.GetSymbolName(x,msg);
Strings.Append(msg," ");
Strings.Append(msg,text);
diagnostics.Warning(module.sourceName,x.position,Diagnostics.Invalid,msg);
END Warning;
PROCEDURE Symbol(x: SyntaxTree.Symbol);
BEGIN
IF ~x.used & (x.access * SyntaxTree.Public = {}) & (x.access # SyntaxTree.Hidden) THEN
Warning(x,"never used");
END;
x.Accept(SELF);
END Symbol;
PROCEDURE VisitSymbol*(x: SyntaxTree.Symbol);
BEGIN END VisitSymbol;
PROCEDURE VisitTypeDeclaration*(x: SyntaxTree.TypeDeclaration);
BEGIN Type(x.declaredType) END VisitTypeDeclaration;
PROCEDURE VisitConstant*(x: SyntaxTree.Constant);
BEGIN END VisitConstant;
PROCEDURE VisitVariable*(x: SyntaxTree.Variable);
BEGIN END VisitVariable;
PROCEDURE VisitParameter*(x: SyntaxTree.Parameter);
BEGIN END VisitParameter;
PROCEDURE VisitProcedure*(x: SyntaxTree.Procedure);
BEGIN Scope(x.procedureScope) END VisitProcedure;
PROCEDURE VisitOperator*(x: SyntaxTree.Operator);
BEGIN END VisitOperator;
PROCEDURE VisitImport*(x: SyntaxTree.Import);
BEGIN END VisitImport;
PROCEDURE Scope(scope: SyntaxTree.Scope);
VAR
symbol: SyntaxTree.Symbol;
BEGIN
symbol := scope.firstSymbol;
WHILE(symbol # NIL) DO
Symbol(symbol);
symbol := symbol.nextSymbol;
END;
END Scope;
PROCEDURE Module*(x: SyntaxTree.Module);
BEGIN
SELF.module := x;
Scope(x.moduleScope);
END Module;
END Warnings;
PROCEDURE Resolved(x: SyntaxTree.Type): SyntaxTree.Type;
BEGIN
IF x = NIL THEN RETURN NIL ELSE RETURN x.resolved END;
END Resolved;
PROCEDURE PowerOf2(x: LONGINT): BOOLEAN;
VAR i: LONGINT;
BEGIN
i := 1;
WHILE i < x DO
i := i *2
END;
IF i # x THEN RETURN FALSE ELSE RETURN TRUE END;
END PowerOf2;
PROCEDURE ToMemoryUnits(system: Global.System; size: LONGINT): LONGINT;
BEGIN
ASSERT(size MOD system.dataUnit = 0);
RETURN size DIV system.dataUnit
END ToMemoryUnits;
PROCEDURE GetProcedureAllowed*(type: SyntaxTree.Type) : BOOLEAN;
VAR procedureType: SyntaxTree.ProcedureType; numberParameters: LONGINT;
PROCEDURE TypeAllowed(t : SyntaxTree.Type) : BOOLEAN;
BEGIN
IF t = NIL THEN
RETURN TRUE
ELSE
t := t.resolved;
RETURN (t IS SyntaxTree.RecordType) OR IsPointerToRecord(t);
END;
END TypeAllowed;
BEGIN
type := type.resolved;
IF ~(type IS SyntaxTree.ProcedureType) THEN
RETURN FALSE
ELSE
procedureType := type(SyntaxTree.ProcedureType);
numberParameters := procedureType.numberParameters;
RETURN
(numberParameters = 0) & TypeAllowed(procedureType.returnType) OR
(numberParameters = 1) & TypeAllowed(procedureType.firstParameter.type) & TypeAllowed(procedureType.returnType) OR
(numberParameters = 1) & (procedureType.firstParameter.ownerType.resolved IS SyntaxTree.AnyType) & (procedureType.returnType.resolved IS SyntaxTree.AnyType)
END;
END GetProcedureAllowed;
PROCEDURE RemoveModuleFromCache*(importCache: SyntaxTree.ModuleScope; x: SyntaxTree.Module);
VAR import: SyntaxTree.Import;
BEGIN
import := importCache.ImportByModuleName(x.name,x.context);
IF import # NIL THEN
importCache.RemoveImporters(x.name,x.context);
END;
END RemoveModuleFromCache;
PROCEDURE CompatibleTo(system: Global.System; this,to: SyntaxTree.Type): BOOLEAN;
VAR result: BOOLEAN;
BEGIN
IF this= NIL THEN result := (to=NIL)
ELSIF to=NIL THEN result := FALSE
ELSE
this := this.resolved; to := to.resolved;
IF to=SyntaxTree.invalidType THEN result := FALSE
ELSIF to = this THEN
result := ~(to IS SyntaxTree.ArrayType) OR (to(SyntaxTree.ArrayType).form # SyntaxTree.Open);
ELSIF to IS SyntaxTree.BasicType THEN
IF (to IS SyntaxTree.NumberType) & (this IS SyntaxTree.NumberType) THEN
IF (to IS SyntaxTree.ComplexType) OR (this IS SyntaxTree.ComplexType) THEN
result := this.CompatibleTo(to.resolved)
ELSE
result := Global.BasicTypeDistance(system,this(SyntaxTree.BasicType),to(SyntaxTree.BasicType)) < Infinity;
END
ELSIF (to IS SyntaxTree.SetType) & (this IS SyntaxTree.SetType) THEN
result := to.sizeInBits = this.sizeInBits;
ELSIF (to IS SyntaxTree.IntegerType) & (this IS SyntaxTree.AddressType) THEN
result := to.sizeInBits >= this.sizeInBits;
ELSIF (to IS SyntaxTree.IntegerType) & (this IS SyntaxTree.SizeType) THEN
result := to.sizeInBits >= this.sizeInBits;
ELSIF (to IS SyntaxTree.FloatType) & (this IS SyntaxTree.AddressType) OR (this IS SyntaxTree.SizeType) THEN
result := TRUE;
ELSIF to IS SyntaxTree.AnyType THEN
result := (this IS SyntaxTree.RecordType) & this(SyntaxTree.RecordType).isObject OR (this IS SyntaxTree.PointerType) OR (this IS SyntaxTree.ProcedureType) OR (this IS SyntaxTree.NilType) OR (this IS SyntaxTree.AnyType) OR (this IS SyntaxTree.ObjectType);
ELSIF to IS SyntaxTree.ObjectType THEN
result := IsPointerToRecord(this) OR (this IS SyntaxTree.NilType) OR (this IS SyntaxTree.ObjectType) OR (this IS SyntaxTree.AnyType) ;
ELSIF to IS SyntaxTree.ByteType THEN
result := (this IS SyntaxTree.IntegerType) & (to.sizeInBits = 8) OR IsCharacterType(this)
ELSIF to IS SyntaxTree.CharacterType THEN
result := IsCharacterType(this)
ELSIF (to IS SyntaxTree.SizeType) & ((this IS SyntaxTree.SizeType) OR (this IS SyntaxTree.IntegerType) OR (this IS SyntaxTree.AddressType)) THEN
result := to.sizeInBits >= this.sizeInBits
ELSIF (to IS SyntaxTree.AddressType) & ((this IS SyntaxTree.AddressType) OR (this IS SyntaxTree.IntegerType) OR (this IS SyntaxTree.SizeType)) THEN
result := to.sizeInBits >= this.sizeInBits;
ELSIF (to IS SyntaxTree.RangeType) & (this IS SyntaxTree.RangeType) THEN
result := TRUE;
ELSE
result := FALSE
END;
ELSIF to IS SyntaxTree.PointerType THEN
result := IsPointerType(this) & (IsTypeExtension(to,this) OR ((to(SyntaxTree.PointerType).pointerBase.resolved IS SyntaxTree.ArrayType) & SameType(to,this)))
& (~to.isRealtime OR this.isRealtime) OR (this IS SyntaxTree.NilType)
ELSIF to IS SyntaxTree.ProcedureType THEN
result := (this IS SyntaxTree.NilType) OR (this IS SyntaxTree.ProcedureType) & SameType(to(SyntaxTree.ProcedureType),this(SyntaxTree.ProcedureType))
& (~(this(SyntaxTree.ProcedureType).isDelegate) OR (to(SyntaxTree.ProcedureType).isDelegate))
& (~to.isRealtime OR this.isRealtime)
& ((this(SyntaxTree.ProcedureType).stackAlignment <=1) OR (this(SyntaxTree.ProcedureType).stackAlignment <= to(SyntaxTree.ProcedureType).stackAlignment));
ELSIF (to IS SyntaxTree.RecordType) & to(SyntaxTree.RecordType).isObject THEN
result := (this IS SyntaxTree.NilType) OR IsTypeExtension(to,this);
ELSIF to IS SyntaxTree.RecordType THEN
result := (this IS SyntaxTree.RecordType) & IsTypeExtension(to,this);
ELSIF to IS SyntaxTree.ArrayType THEN
IF IsStringType(to) & (this IS SyntaxTree.StringType) THEN
result := (to(SyntaxTree.ArrayType).form = SyntaxTree.Open) OR (to(SyntaxTree.ArrayType).staticLength >= this(SyntaxTree.StringType).length)
ELSIF StaticArrayCompatible(to, this) THEN
result := TRUE
ELSE
result := (to(SyntaxTree.ArrayType).staticLength # 0) & SameType(to,this)
END;
ELSIF to IS SyntaxTree.MathArrayType THEN
IF this IS SyntaxTree.MathArrayType THEN
IF to(SyntaxTree.MathArrayType).arrayBase= NIL THEN
IF to(SyntaxTree.MathArrayType).form = SyntaxTree.Tensor THEN
result := TRUE;
ELSIF this(SyntaxTree.MathArrayType).arrayBase = NIL THEN
result := TRUE;
ELSE
result := ~(this(SyntaxTree.MathArrayType).arrayBase.resolved IS SyntaxTree.MathArrayType);
END;
ELSIF (to(SyntaxTree.MathArrayType).form = SyntaxTree.Tensor) OR (this(SyntaxTree.MathArrayType).form = SyntaxTree.Tensor) THEN
result := CompatibleTo(system,ArrayBase(this,Infinity),ArrayBase(to,Infinity));
ELSIF (to(SyntaxTree.MathArrayType).form = SyntaxTree.Open) OR (this(SyntaxTree.MathArrayType).form = SyntaxTree.Open)
OR (to(SyntaxTree.MathArrayType).staticLength = this(SyntaxTree.MathArrayType).staticLength) THEN
result := CompatibleTo(system,this(SyntaxTree.MathArrayType).arrayBase,to(SyntaxTree.MathArrayType).arrayBase);
ELSE
result := FALSE
END;
ELSIF IsArrayStructuredObjectType(this) THEN
result := CompatibleTo(system, to, MathArrayStructureOfType(this))
ELSE
result := FALSE;
END;
ELSIF to IS SyntaxTree.StringType THEN
result := FALSE;
ELSIF to IS SyntaxTree.EnumerationType THEN
result := IsEnumerationExtension(this,to);
ELSIF to IS SyntaxTree.PortType THEN
result := SameType(to, this)
ELSE
Printout.Info("CompatibleTo",to);
HALT(100);
END;
END;
RETURN result
END CompatibleTo;
PROCEDURE StaticArrayCompatible(formal: SyntaxTree.Type; actual: SyntaxTree.Type): BOOLEAN;
VAR actualBase, formalBase: SyntaxTree.Type; result: BOOLEAN;
BEGIN
IF SameType(formal,actual) THEN
RETURN TRUE
ELSIF (formal IS SyntaxTree.MathArrayType) & (actual IS SyntaxTree.ArrayType) THEN
actualBase := actual(SyntaxTree.ArrayType).arrayBase.resolved;
formalBase := formal(SyntaxTree.MathArrayType).arrayBase.resolved;
RETURN
(formal(SyntaxTree.MathArrayType).form = SyntaxTree.Static)
& (actual(SyntaxTree.ArrayType).form = SyntaxTree.Static)
& (actual(SyntaxTree.ArrayType).staticLength = formal(SyntaxTree.MathArrayType).staticLength)
& StaticArrayCompatible(formalBase,actualBase)
ELSIF (formal IS SyntaxTree.ArrayType) & (actual IS SyntaxTree.MathArrayType) THEN
actualBase := actual(SyntaxTree.MathArrayType).arrayBase.resolved;
formalBase := formal(SyntaxTree.ArrayType).arrayBase.resolved;
RETURN
(formal(SyntaxTree.ArrayType).form = SyntaxTree.Static)
& (actual(SyntaxTree.MathArrayType).form = SyntaxTree.Static)
& (actual(SyntaxTree.MathArrayType).staticLength = formal(SyntaxTree.ArrayType).staticLength)
& StaticArrayCompatible(formalBase,actualBase)
ELSE RETURN FALSE
END;
END StaticArrayCompatible;
PROCEDURE OpenArrayCompatible(formalType: SyntaxTree.ArrayType; actualType: SyntaxTree.Type): BOOLEAN;
VAR arrayBase: SyntaxTree.Type; result: BOOLEAN;
PROCEDURE TC(formal,actual: SyntaxTree.Type): BOOLEAN;
VAR actualBase,formalBase: SyntaxTree.Type; result: BOOLEAN;
BEGIN
result := SameType(formal,actual);
IF ~result & (formal IS SyntaxTree.ArrayType) & (actual IS SyntaxTree.ArrayType) THEN
actualBase := actual(SyntaxTree.ArrayType).arrayBase.resolved;
formalBase := formal(SyntaxTree.ArrayType).arrayBase.resolved;
result := (formal(SyntaxTree.ArrayType).form = SyntaxTree.Open) & TC(formalBase,actualBase)
ELSIF ~result & (formal IS SyntaxTree.ArrayType) & (actual IS SyntaxTree.MathArrayType) THEN
actualBase := actual(SyntaxTree.MathArrayType).arrayBase.resolved;
formalBase := formal(SyntaxTree.ArrayType).arrayBase.resolved;
result := (formal(SyntaxTree.ArrayType).form = SyntaxTree.Open) & (actual(SyntaxTree.MathArrayType).form = SyntaxTree.Static)
& TC(formalBase, actualBase);
END;
RETURN result
END TC;
BEGIN
IF formalType.form # SyntaxTree.Open THEN result := FALSE
ELSE
arrayBase := formalType.arrayBase.resolved;
IF (actualType IS SyntaxTree.StringType) THEN
result := arrayBase IS SyntaxTree.CharacterType
ELSIF actualType IS SyntaxTree.ArrayType THEN
result := (arrayBase IS SyntaxTree.ByteType) OR TC(formalType,actualType)
ELSIF actualType IS SyntaxTree.MathArrayType THEN
result := TC(formalType, actualType);
ELSE
result := (arrayBase IS SyntaxTree.ByteType)
END;
END;
RETURN result
END OpenArrayCompatible;
PROCEDURE MathArrayCompatible(formalType: SyntaxTree.MathArrayType; actualType: SyntaxTree.Type): BOOLEAN;
VAR formalBase,actualBase: SyntaxTree.Type; result: BOOLEAN; actualArray: SyntaxTree.MathArrayType;
BEGIN
IF actualType IS SyntaxTree.MathArrayType THEN
actualArray := actualType(SyntaxTree.MathArrayType);
IF (formalType.form = SyntaxTree.Tensor) OR (actualArray.form = SyntaxTree.Tensor) THEN
actualBase := ArrayBase(actualType,Infinity);
formalBase := ArrayBase(formalType,Infinity);
result := (formalBase = NIL) OR SameType(formalBase,actualBase);
ELSE
formalBase := Resolved(formalType.arrayBase);
actualBase := Resolved(actualArray.arrayBase);
IF (formalType.form = SyntaxTree.Static) & (actualArray.form = SyntaxTree.Static) THEN
result := (formalType.staticLength = actualArray.staticLength)
ELSE
result := TRUE
END;
IF ~result THEN
ELSIF formalBase = NIL THEN result := (actualBase = NIL) OR ~(actualBase IS SyntaxTree.MathArrayType);
ELSIF actualBase = NIL THEN result := FALSE
ELSIF formalBase IS SyntaxTree.MathArrayType THEN
result := MathArrayCompatible(formalBase(SyntaxTree.MathArrayType),actualBase)
ELSE
result := SameType(formalBase,actualBase)
END;
END;
ELSE
result := FALSE
END;
RETURN result
END MathArrayCompatible;
PROCEDURE MathArrayTypeDistance(system: Global.System; from,to: SyntaxTree.MathArrayType; varpar:BOOLEAN): LONGINT;
VAR i: LONGINT; fromBase, toBase: SyntaxTree.Type;
BEGIN
fromBase := Resolved(from.arrayBase);
toBase := Resolved(to.arrayBase);
i := Infinity;
IF from = to THEN
i := 0;
ELSIF (from.form = to.form) THEN
IF (from.form # SyntaxTree.Static) OR (from.staticLength = to.staticLength) THEN
IF fromBase = toBase THEN i := 0
ELSIF toBase = NIL THEN i := 1
ELSIF (fromBase IS SyntaxTree.MathArrayType) & (toBase IS SyntaxTree.MathArrayType) THEN
i := MathArrayTypeDistance(system,fromBase(SyntaxTree.MathArrayType),toBase(SyntaxTree.MathArrayType),varpar);
ELSE
i := TypeDistance(system,fromBase, toBase, varpar);
END;
END;
ELSIF (to.form = SyntaxTree.Static) THEN
ELSIF (from.form = SyntaxTree.Tensor) OR (to.form = SyntaxTree.Tensor) THEN
IF toBase=fromBase THEN i := 0;
ELSIF toBase = NIL THEN i := 1;
ELSIF (toBase IS SyntaxTree.MathArrayType) THEN
toBase := ArrayBase(toBase,Infinity);
IF (fromBase=toBase) THEN i := 0
ELSIF (toBase = NIL) THEN i:= 1
ELSIF (fromBase = NIL) THEN i := Infinity;
ELSE i := TypeDistance(system,fromBase,toBase,varpar);
END;
ELSIF (fromBase IS SyntaxTree.MathArrayType) THEN
fromBase := ArrayBase(fromBase,Infinity);
IF (fromBase=toBase) THEN i := 0
ELSIF (toBase = NIL) THEN i := 1
ELSIF (fromBase = NIL) THEN i := Infinity;
ELSE i := TypeDistance(system,fromBase,toBase,varpar);
END;
ELSE i := TypeDistance(system, fromBase, toBase, varpar);
END;
IF i # Infinity THEN INC(i,2) END;
ELSIF (from.form = SyntaxTree.Static) THEN
IF toBase=fromBase THEN i := 0
ELSIF toBase = NIL THEN i := 1
ELSIF fromBase = NIL THEN i := Infinity
ELSIF (toBase IS SyntaxTree.MathArrayType) & (fromBase IS SyntaxTree.MathArrayType) THEN
i := MathArrayTypeDistance(system,fromBase(SyntaxTree.MathArrayType),toBase(SyntaxTree.MathArrayType),varpar);
ELSE i := TypeDistance(system,fromBase, toBase, varpar);
END;
IF i # Infinity THEN INC(i,1) END;
ELSE HALT(100);
END;
RETURN i;
END MathArrayTypeDistance;
PROCEDURE ArrayTypeDistance(system: Global.System; from, to: SyntaxTree.ArrayType): LONGINT;
VAR i: LONGINT;
BEGIN
i := Infinity;
IF from = to THEN
i := 0
ELSE
i := TypeDistance(system,from.arrayBase.resolved, to.arrayBase.resolved,FALSE);
END;
RETURN i
END ArrayTypeDistance;
PROCEDURE Distance(system: Global.System; procedureType: SyntaxTree.ProcedureType; actualParameters: SyntaxTree.ExpressionList): LONGINT;
VAR result: LONGINT; formalParameter: SyntaxTree.Parameter; actualParameter: SyntaxTree.Expression;
distance: LONGINT; baseFormal,baseActual: SyntaxTree.Type; i: LONGINT;
BEGIN
IF actualParameters.Length() # (procedureType.numberParameters) THEN
result := Infinity
ELSE
formalParameter := procedureType.firstParameter;
i := 0;
result := 0;
WHILE (formalParameter # NIL) & (result # Infinity) DO
actualParameter := actualParameters.GetExpression(i);
ASSERT(formalParameter.type # NIL);
IF (actualParameter.type = NIL) THEN distance := Infinity
ELSE
distance := TypeDistance(system,actualParameter.type.resolved,formalParameter.type.resolved,formalParameter.kind = SyntaxTree.VarParameter);
END;
IF distance = Infinity THEN
result := Infinity;
ELSE
IF (formalParameter.kind = SyntaxTree.VarParameter) & (distance # 0) THEN
IF (formalParameter.type.resolved IS SyntaxTree.MathArrayType) & (actualParameter.type.resolved IS SyntaxTree.MathArrayType) THEN
ELSIF (formalParameter.type.resolved IS SyntaxTree.ArrayType) & (actualParameter.type.resolved IS SyntaxTree.ArrayType) THEN
baseActual := actualParameter.type.resolved(SyntaxTree.ArrayType).arrayBase.resolved;
baseFormal := formalParameter.type.resolved(SyntaxTree.ArrayType).arrayBase.resolved;
WHILE(baseActual IS SyntaxTree.ArrayType) & (baseFormal IS SyntaxTree.ArrayType) DO
baseActual := baseActual(SyntaxTree.ArrayType).arrayBase.resolved;
baseFormal := baseFormal(SyntaxTree.ArrayType).arrayBase.resolved;
END;
IF TypeDistance(system,baseActual,baseFormal,FALSE) # 0 THEN
result := Infinity
END;
ELSE
result := Infinity
END;
ELSE
INC(result,distance);
END;
END;
formalParameter := formalParameter.nextParameter; INC(i);
END;
END;
ASSERT(result >= 0);
RETURN result
END Distance;
PROCEDURE TypeDistance(system: Global.System; from, to: SyntaxTree.Type; varpar: BOOLEAN): LONGINT;
VAR i: LONGINT; ptr: SyntaxTree.PointerType;
BEGIN
IF IsArrayStructuredObjectType(from) & (to IS SyntaxTree.MathArrayType) THEN
RETURN TypeDistance(system, MathArrayStructureOfType(from), to, varpar) + 0;
END;
i := Infinity;
IF from = to THEN
i := 0
ELSIF (to = NIL) OR (from=NIL) THEN HALT(100);
ELSIF (from IS SyntaxTree.NilType) OR (to IS SyntaxTree.NilType) THEN
i := Infinity;
ELSIF (to IS SyntaxTree.ArrayType) & (to(SyntaxTree.ArrayType).length = NIL) & (to(SyntaxTree.ArrayType).arrayBase.resolved IS SyntaxTree.ByteType) THEN
i := 1
ELSIF (from IS SyntaxTree.StringType) THEN
IF (to IS SyntaxTree.ArrayType) & (to(SyntaxTree.ArrayType).length = NIL) & (to(SyntaxTree.ArrayType).arrayBase.resolved IS SyntaxTree.CharacterType) THEN i := 1 END
ELSIF (from IS SyntaxTree.CharacterType) THEN
IF (to IS SyntaxTree.ArrayType) & (to(SyntaxTree.ArrayType).length = NIL) & (to(SyntaxTree.ArrayType).arrayBase.resolved IS SyntaxTree.CharacterType) THEN i := 1
ELSIF to IS SyntaxTree.ByteType THEN i := 1 END
ELSIF (from IS SyntaxTree.IntegerType) & (to IS SyntaxTree.ByteType) & (to.sizeInBits = from.sizeInBits) THEN
i := 1
ELSIF (from IS SyntaxTree.NilType) THEN
IF (to IS SyntaxTree.AnyType) OR (to IS SyntaxTree.ObjectType) OR (to IS SyntaxTree.PointerType) OR (to IS SyntaxTree.ProcedureType) THEN i := 1 END
ELSIF (from IS SyntaxTree.BasicType) THEN
IF to IS SyntaxTree.BasicType THEN i := Global.BasicTypeDistance(system,from(SyntaxTree.BasicType), to(SyntaxTree.BasicType)) END;
IF varpar & (i # 0) THEN i := Infinity END;
ELSIF (from IS SyntaxTree.ArrayType) THEN
IF to IS SyntaxTree.ArrayType THEN i := ArrayTypeDistance(system,from(SyntaxTree.ArrayType), to(SyntaxTree.ArrayType)) END
ELSIF (from IS SyntaxTree.RecordType) THEN
IF to IS SyntaxTree.RecordType THEN i := RecordTypeDistance(from(SyntaxTree.RecordType), to (SyntaxTree.RecordType)) END
ELSIF (from IS SyntaxTree.MathArrayType) THEN
IF to IS SyntaxTree.MathArrayType THEN
i := MathArrayTypeDistance(system,from(SyntaxTree.MathArrayType), to(SyntaxTree.MathArrayType),varpar)
END
ELSIF (from IS SyntaxTree.PointerType) THEN
ptr := from(SyntaxTree.PointerType);
IF (to IS SyntaxTree.AnyType) THEN i := 1
ELSIF to IS SyntaxTree.PointerType THEN i := PointerTypeDistance(ptr, to(SyntaxTree.PointerType))
END
END;
RETURN i
END TypeDistance;
PROCEDURE IsIntegerType*(type: SyntaxTree.Type): BOOLEAN;
BEGIN
RETURN (type # NIL) & ((type IS SyntaxTree.IntegerType) OR (type IS SyntaxTree.AddressType) OR (type IS SyntaxTree.SizeType))
END IsIntegerType;
PROCEDURE IsIntegerValue(x: SyntaxTree.Expression; VAR value: LONGINT): BOOLEAN;
VAR result: BOOLEAN;
BEGIN
IF (x.resolved # NIL) & (x.resolved IS SyntaxTree.IntegerValue) THEN
value := x.resolved(SyntaxTree.IntegerValue).value;
result := TRUE
ELSE
result := FALSE
END;
RETURN result
END IsIntegerValue;
PROCEDURE IsEnumerationValue(x: SyntaxTree.Expression; VAR value: LONGINT): BOOLEAN;
VAR result: BOOLEAN;
BEGIN
IF (x.resolved # NIL) & (x.resolved IS SyntaxTree.EnumerationValue) THEN
value := x.resolved(SyntaxTree.EnumerationValue).value;
result := TRUE
ELSE
result := FALSE
END;
RETURN result
END IsEnumerationValue;
PROCEDURE IsRealValue(x: SyntaxTree.Expression; VAR value: LONGREAL): BOOLEAN;
VAR result: BOOLEAN;
BEGIN
IF (x.resolved # NIL) & (x.resolved IS SyntaxTree.RealValue) THEN
value := x.resolved(SyntaxTree.RealValue).value;
result := TRUE
ELSE
result := FALSE
END;
RETURN result
END IsRealValue;
PROCEDURE IsComplexValue(x: SyntaxTree.Expression; VAR realValue, imagValue: LONGREAL): BOOLEAN;
VAR result: BOOLEAN;
BEGIN
IF (x.resolved # NIL) & (x.resolved IS SyntaxTree.ComplexValue) THEN
realValue := x.resolved(SyntaxTree.ComplexValue).realValue;
imagValue := x.resolved(SyntaxTree.ComplexValue).imagValue;
result := TRUE
ELSE
result := FALSE
END;
RETURN result
END IsComplexValue;
PROCEDURE IsCharacterValue(x: SyntaxTree.Expression; VAR value: CHAR): BOOLEAN;
VAR result: BOOLEAN;
BEGIN
IF (x.resolved # NIL) & (x.resolved IS SyntaxTree.CharacterValue) THEN
value := x.resolved(SyntaxTree.CharacterValue).value;
result := TRUE
ELSE
result := FALSE
END;
RETURN result
END IsCharacterValue;
PROCEDURE IsBooleanValue*(x: SyntaxTree.Expression; VAR value: BOOLEAN): BOOLEAN;
VAR result: BOOLEAN;
BEGIN
IF (x.resolved # NIL) & (x.resolved IS SyntaxTree.BooleanValue) THEN
value := x.resolved(SyntaxTree.BooleanValue).value;
result := TRUE
ELSE
result := FALSE
END;
RETURN result
END IsBooleanValue;
PROCEDURE IsSetValue(x: SyntaxTree.Expression; VAR value: SET): BOOLEAN;
VAR result: BOOLEAN;
BEGIN
IF (x.resolved # NIL) & (x.resolved IS SyntaxTree.SetValue) THEN
value := x.resolved(SyntaxTree.SetValue).value;
result := TRUE
ELSE
result := FALSE
END;
RETURN result
END IsSetValue;
PROCEDURE IsStringValue(x: SyntaxTree.Expression; VAR value: Scanner.StringType): BOOLEAN;
VAR result: BOOLEAN;
BEGIN
IF (x.resolved # NIL) & (x.resolved IS SyntaxTree.StringValue) THEN
value := x.resolved(SyntaxTree.StringValue).value;
result := TRUE
ELSE
result := FALSE
END;
RETURN result
END IsStringValue;
PROCEDURE Indexable(x: SyntaxTree.Type): BOOLEAN;
BEGIN
x := x.resolved;
RETURN (x IS SyntaxTree.ArrayType) OR (x IS SyntaxTree.MathArrayType);
END Indexable;
PROCEDURE SameType(t1,t2: SyntaxTree.Type): BOOLEAN;
BEGIN
RETURN t1.SameType(t2.resolved);
END SameType;
PROCEDURE ArrayBase*(t: SyntaxTree.Type; max: LONGINT): SyntaxTree.Type;
BEGIN
IF t IS SyntaxTree.MathArrayType THEN
WHILE (t # NIL) & (t IS SyntaxTree.MathArrayType) & ((t(SyntaxTree.MathArrayType).form # SyntaxTree.Tensor) OR (max = Infinity)) & (max > 0) DO
t := Resolved(t(SyntaxTree.MathArrayType).arrayBase);
IF (t # NIL) & (t IS SyntaxTree.PointerType) & (t(SyntaxTree.PointerType).pointerBase.resolved IS SyntaxTree.MathArrayType) THEN t := t(SyntaxTree.PointerType).pointerBase.resolved END;
DEC(max);
END;
ELSIF t IS SyntaxTree.ArrayType THEN
WHILE (t IS SyntaxTree.ArrayType) & (max > 0) DO
t := t(SyntaxTree.ArrayType).arrayBase.resolved; DEC(max);
IF (t IS SyntaxTree.PointerType) & (t(SyntaxTree.PointerType).pointerBase.resolved IS SyntaxTree.ArrayType) THEN t := t(SyntaxTree.PointerType).pointerBase.resolved END;
END;
END;
RETURN t;
END ArrayBase;
PROCEDURE IsStaticArray*(type: SyntaxTree.Type; VAR base: SyntaxTree.Type; VAR dim :LONGINT): BOOLEAN;
BEGIN
type := type.resolved;
IF (type IS SyntaxTree.ArrayType) & (type(SyntaxTree.ArrayType).form = SyntaxTree.Static) THEN
base := type(SyntaxTree.ArrayType).arrayBase;
dim := type(SyntaxTree.ArrayType).staticLength;
RETURN TRUE
ELSE
RETURN FALSE
END;
END IsStaticArray;
PROCEDURE Dimension*(t: SyntaxTree.Type; form: SET): LONGINT;
VAR i: LONGINT;
BEGIN
i := 0;
t := t.resolved;
IF t IS SyntaxTree.MathArrayType THEN
WHILE (t # NIL) & (t IS SyntaxTree.MathArrayType) & (t(SyntaxTree.MathArrayType).form IN form) DO
t := Resolved(t(SyntaxTree.MathArrayType).arrayBase); INC(i);
END;
ELSIF t IS SyntaxTree.ArrayType THEN
WHILE(t IS SyntaxTree.ArrayType) & (t(SyntaxTree.ArrayType).form IN form) DO
t := t(SyntaxTree.ArrayType).arrayBase.resolved; INC(i);
END;
END;
RETURN i
END Dimension;
PROCEDURE IsVariable(expression: SyntaxTree.Expression): BOOLEAN;
BEGIN
RETURN expression.assignable;
END IsVariable;
PROCEDURE IsPointerType*(type: SyntaxTree.Type): BOOLEAN;
VAR result: BOOLEAN;
BEGIN
IF type = NIL THEN result := FALSE
ELSE
type := type.resolved;
result := (type IS SyntaxTree.AnyType) OR (type IS SyntaxTree.PointerType) OR (type IS SyntaxTree.NilType) OR (type IS SyntaxTree.ObjectType)
END;
RETURN result
END IsPointerType;
PROCEDURE IsStrictlyPointerToRecord(type: SyntaxTree.Type): BOOLEAN;
BEGIN
IF type = NIL THEN
RETURN FALSE
ELSIF type.resolved IS SyntaxTree.PointerType THEN
RETURN type.resolved(SyntaxTree.PointerType).pointerBase.resolved IS SyntaxTree.RecordType
ELSE
RETURN FALSE
END
END IsStrictlyPointerToRecord;
PROCEDURE IsPointerToRecord(type: SyntaxTree.Type): BOOLEAN;
VAR result: BOOLEAN;
BEGIN
IF type = NIL THEN result := FALSE
ELSE
type := type.resolved;
result := (type IS SyntaxTree.PointerType) & (type(SyntaxTree.PointerType).pointerBase.resolved IS SyntaxTree.RecordType);
result := result OR (type IS SyntaxTree.RecordType) & (type(SyntaxTree.RecordType).pointerType # NIL);
result := result OR (type IS SyntaxTree.ObjectType);
END;
RETURN result
END IsPointerToRecord;
PROCEDURE ContainsPointer*(type: SyntaxTree.Type): BOOLEAN;
BEGIN
IF type # NIL THEN
RETURN type.resolved.hasPointers
ELSE
RETURN FALSE
END;
END ContainsPointer;
PROCEDURE IsStringType*(type: SyntaxTree.Type): BOOLEAN;
BEGIN
IF type = NIL THEN RETURN FALSE END;
type := type.resolved;
RETURN (type IS SyntaxTree.StringType) OR (type IS SyntaxTree.ArrayType) & (type(SyntaxTree.ArrayType).arrayBase.resolved IS SyntaxTree.CharacterType);
END IsStringType;
PROCEDURE IsCharacterType*(type: SyntaxTree.Type):BOOLEAN;
BEGIN
IF type = NIL THEN RETURN FALSE END;
type := type.resolved;
RETURN (type IS SyntaxTree.CharacterType) OR (type IS SyntaxTree.ByteType) OR (type IS SyntaxTree.StringType) & (type(SyntaxTree.StringType).length = 2)
END IsCharacterType;
PROCEDURE IsEnumerationType*(type: SyntaxTree.Type):BOOLEAN;
BEGIN
IF type = NIL THEN RETURN FALSE END;
type := type.resolved;
RETURN (type IS SyntaxTree.EnumerationType)
END IsEnumerationType;
PROCEDURE IsTypeExtension(base,extension: SyntaxTree.Type): BOOLEAN;
VAR result: BOOLEAN;
BEGIN
ASSERT(base # NIL); ASSERT(extension # NIL);
base := base.resolved; extension := extension.resolved;
IF ( (base IS SyntaxTree.ObjectType) OR (base IS SyntaxTree.AnyType)) & IsPointerToRecord(extension) THEN
result := TRUE;
ELSE
IF (base IS SyntaxTree.PointerType) & (extension IS SyntaxTree.PointerType) THEN
base := base(SyntaxTree.PointerType).pointerBase.resolved;
extension := extension(SyntaxTree.PointerType).pointerBase.resolved;
END;
WHILE (extension # NIL) & (extension # base) DO
IF extension IS SyntaxTree.RecordType THEN
extension := extension(SyntaxTree.RecordType).baseType;
IF (extension # NIL) THEN extension := extension.resolved END;
IF (extension # NIL) & (extension IS SyntaxTree.PointerType) THEN
extension := extension(SyntaxTree.PointerType).pointerBase.resolved;
END;
ELSE extension := NIL;
END;
END;
result := (extension = base) & (extension IS SyntaxTree.RecordType);
END;
RETURN result
END IsTypeExtension;
PROCEDURE IsEnumerationExtension(base,extension: SyntaxTree.Type): BOOLEAN;
BEGIN
base := base.resolved; extension := extension.resolved;
WHILE (extension # NIL) & (extension # base) DO
IF extension IS SyntaxTree.EnumerationType THEN
extension := extension(SyntaxTree.EnumerationType).enumerationBase;
IF extension # NIL THEN extension := extension.resolved END;
ELSE
extension := NIL
END;
END;
RETURN (extension = base) & (base IS SyntaxTree.EnumerationType);
END IsEnumerationExtension;
PROCEDURE IsCallable(expression: SyntaxTree.Expression): BOOLEAN;
BEGIN
IF expression IS SyntaxTree.ProcedureCallDesignator THEN
RETURN TRUE
ELSIF expression IS SyntaxTree.BuiltinCallDesignator THEN
RETURN TRUE
ELSIF (expression.type # NIL) & (expression.type.resolved IS SyntaxTree.ProcedureType) THEN
RETURN TRUE
ELSE
RETURN FALSE
END
END IsCallable;
PROCEDURE RecordTypeDistance(from, to: SyntaxTree.RecordType): LONGINT;
VAR i: LONGINT; baseType: SyntaxTree.Type;
BEGIN
i := 0;
WHILE (from # NIL) & (from # to) DO
baseType := from.baseType;
IF (baseType # NIL) THEN
baseType := baseType.resolved;
IF baseType IS SyntaxTree.PointerType THEN
baseType := baseType(SyntaxTree.PointerType).pointerBase.resolved;
END;
IF baseType IS SyntaxTree.RecordType THEN
from := baseType(SyntaxTree.RecordType);
ELSE
from := NIL;
END;
ELSE
from := NIL
END;
INC(i)
END;
IF from = NIL THEN i := Infinity END;
RETURN i
END RecordTypeDistance;
PROCEDURE PointerTypeDistance(from, to: SyntaxTree.PointerType): LONGINT;
BEGIN
IF ~((to.pointerBase.resolved IS SyntaxTree.RecordType) & (from.pointerBase.resolved IS SyntaxTree.RecordType)) THEN
RETURN Infinity;
ELSE
RETURN RecordTypeDistance(from.pointerBase.resolved(SyntaxTree.RecordType), to.pointerBase.resolved(SyntaxTree.RecordType));
END;
END PointerTypeDistance;
PROCEDURE IsTypeDesignator(expression: SyntaxTree.Expression; VAR typeDeclaration: SyntaxTree.TypeDeclaration): BOOLEAN;
VAR result: BOOLEAN;
BEGIN
result := FALSE;
IF (expression # NIL) & (expression.type.resolved = SyntaxTree.typeDeclarationType) THEN
result := TRUE;
typeDeclaration := expression(SyntaxTree.SymbolDesignator).symbol(SyntaxTree.TypeDeclaration)
END;
RETURN result
END IsTypeDesignator;
PROCEDURE IsExtensibleType( type: SyntaxTree.Type): BOOLEAN;
VAR result: BOOLEAN;
BEGIN
type := type.resolved;
IF type IS SyntaxTree.PointerType THEN
result := IsExtensibleType(type(SyntaxTree.PointerType).pointerBase.resolved);
ELSIF (type IS SyntaxTree.AnyType) OR (type IS SyntaxTree.ObjectType) THEN
result := TRUE
ELSE
result := type IS SyntaxTree.RecordType
END;
RETURN result
END IsExtensibleType;
PROCEDURE IsUnextensibleRecord(d: SyntaxTree.Expression): BOOLEAN;
BEGIN
RETURN (d.type.resolved IS SyntaxTree.RecordType) &
(d IS SyntaxTree.SymbolDesignator) &
( (d(SyntaxTree.SymbolDesignator).symbol IS SyntaxTree.Variable)
OR
(d(SyntaxTree.SymbolDesignator).symbol IS SyntaxTree.Parameter) & (d(SyntaxTree.SymbolDesignator).symbol(SyntaxTree.Parameter).kind = SyntaxTree.ValueParameter));
END IsUnextensibleRecord;
PROCEDURE IsExtensibleDesignator(d: SyntaxTree.Expression): BOOLEAN;
BEGIN
IF IsUnextensibleRecord(d) THEN
RETURN FALSE
ELSE RETURN IsExtensibleType(d.type.resolved)
END;
END IsExtensibleDesignator;
PROCEDURE IsBasicType(type: SyntaxTree.Type): BOOLEAN;
BEGIN
type := type.resolved;
IF (type IS SyntaxTree.PointerType) THEN
RETURN TRUE
ELSIF (type IS SyntaxTree.RecordType) & (type(SyntaxTree.RecordType).pointerType # NIL) THEN
RETURN TRUE
ELSIF (type IS SyntaxTree.ProcedureType) THEN
RETURN TRUE
ELSIF (type IS SyntaxTree.BasicType) THEN
RETURN TRUE
END;
RETURN FALSE
END IsBasicType;
PROCEDURE RecordBase*(record: SyntaxTree.RecordType): SyntaxTree.RecordType;
VAR baseType: SyntaxTree.Type; recordType: SyntaxTree.RecordType;
BEGIN
baseType := record.baseType;
IF (baseType # NIL) THEN
baseType := baseType.resolved;
IF (baseType IS SyntaxTree.PointerType) THEN
baseType := baseType(SyntaxTree.PointerType).pointerBase.resolved;
END;
END;
IF (baseType # NIL) & (baseType IS SyntaxTree.RecordType) THEN
recordType := baseType(SyntaxTree.RecordType);
ELSE
recordType := NIL;
END;
RETURN recordType
END RecordBase;
PROCEDURE FindSuperProcedure*(scope: SyntaxTree.RecordScope; procedure: SyntaxTree.Procedure): SyntaxTree.Procedure;
VAR super: SyntaxTree.Procedure; operator: SyntaxTree.Operator; procedureType: SyntaxTree.Type; baseRecord: SyntaxTree.RecordType;
BEGIN
baseRecord := RecordBase(scope.ownerRecord);
IF baseRecord = NIL THEN RETURN NIL END;
scope := baseRecord.recordScope;
procedureType := procedure.type.resolved;
IF procedure IS SyntaxTree.Operator THEN
operator := scope.firstOperator;
WHILE (operator # NIL) & ((operator.name # procedure.name) OR ~SameType(procedureType, operator.type)) DO
operator := operator.nextOperator;
END;
super := operator;
ELSE
super := scope.firstProcedure;
WHILE (super # NIL) & (super.name # procedure.name) DO
super := super.nextProcedure;
END;
END;
IF (super # NIL) & ((super.scope.ownerModule = procedure.scope.ownerModule) OR (SyntaxTree.Public * super.access # {})) THEN
RETURN super
ELSIF (super # NIL) & (FindSuperProcedure(scope,procedure)#NIL) THEN
RETURN super
ELSE
RETURN FindSuperProcedure(scope,procedure);
END;
END FindSuperProcedure;
PROCEDURE GetConstructor(record: SyntaxTree.RecordType): SyntaxTree.Procedure;
VAR procedure: SyntaxTree.Procedure;
BEGIN
procedure := record.recordScope.constructor;
IF procedure = NIL THEN
record := RecordBase(record);
IF record # NIL THEN
procedure := GetConstructor(record)
END;
END;
RETURN procedure;
END GetConstructor;
PROCEDURE EnterCase(VAR root: SyntaxTree.CaseConstant; min,max: LONGINT): BOOLEAN;
VAR prev,this,new: SyntaxTree.CaseConstant;
BEGIN
this := root;
prev := NIL;
WHILE (this # NIL) & (min > this.max) DO prev := this; this := this.next END;
IF (this # NIL) & (max >= this.min) THEN
RETURN FALSE
ELSE
IF (this # NIL) & (this.min = max+1) THEN
this.min := min
ELSIF (prev # NIL) & (min+1 = prev.max) THEN
prev.max := min
ELSE
NEW(new); new.min := min; new.max := max;
new.next := this;
IF prev = NIL THEN
root := new;
ELSE
prev.next := new
END
END;
RETURN TRUE
END;
END EnterCase;
PROCEDURE NewChecker*(diagnostics: Diagnostics.Diagnostics; verboseErrorMessage,useDarwinCCalls: BOOLEAN; system: Global.System; symbolFileFormat: Formats.SymbolFileFormat; activeCellsSpecification: ActiveCells.Specification; VAR importCache: SyntaxTree.ModuleScope): Checker;
VAR checker: Checker;
BEGIN
NEW(checker, diagnostics,verboseErrorMessage,useDarwinCCalls,system,symbolFileFormat,activeCellsSpecification, importCache);
RETURN checker
END NewChecker;
PROCEDURE NewWarnings*(diagnostics: Diagnostics.Diagnostics): Warnings;
VAR warnings: Warnings;
BEGIN
NEW(warnings, diagnostics); RETURN warnings;
END NewWarnings;
PROCEDURE IsRangeType(type: SyntaxTree.Type): BOOLEAN;
BEGIN RETURN (type # NIL) & (type.resolved IS SyntaxTree.RangeType);
END IsRangeType;
PROCEDURE IsMathArrayType(type: SyntaxTree.Type): BOOLEAN;
BEGIN RETURN (type # NIL) & (type.resolved IS SyntaxTree.MathArrayType);
END IsMathArrayType;
PROCEDURE IsArrayType(type: SyntaxTree.Type): BOOLEAN;
BEGIN RETURN (type # NIL) & (type.resolved IS SyntaxTree.ArrayType);
END IsArrayType;
PROCEDURE IsComplexType(type: SyntaxTree.Type): BOOLEAN;
BEGIN RETURN (type # NIL) & (type.resolved IS SyntaxTree.ComplexType);
END IsComplexType;
PROCEDURE IsArrayStructuredObjectType*(type: SyntaxTree.Type): BOOLEAN;
VAR recordType: SyntaxTree.RecordType;
BEGIN
IF type = NIL THEN
RETURN FALSE
ELSE
type := type.resolved;
IF type IS SyntaxTree.PointerType THEN
type := type(SyntaxTree.PointerType).pointerBase.resolved;
IF type IS SyntaxTree.RecordType THEN
recordType := type(SyntaxTree.RecordType);
RETURN recordType.isObject & recordType.HasArrayStructure()
ELSE
RETURN FALSE
END
ELSE
RETURN FALSE
END
END
END IsArrayStructuredObjectType;
PROCEDURE MathArrayStructureOfType(type: SyntaxTree.Type): SyntaxTree.MathArrayType;
VAR
result: SyntaxTree.MathArrayType;
BEGIN
IF type = NIL THEN
result := NIL
ELSE
type := type.resolved;
IF type IS SyntaxTree.PointerType THEN
type := type(SyntaxTree.PointerType).pointerBase.resolved;
END;
IF type IS SyntaxTree.MathArrayType THEN
result := type(SyntaxTree.MathArrayType)
ELSIF type IS SyntaxTree.RecordType THEN
result := type(SyntaxTree.RecordType).arrayStructure
ELSE
result := NIL
END
END;
RETURN result
END MathArrayStructureOfType;
PROCEDURE IsStaticallyOpenRange(x: SyntaxTree.Expression): BOOLEAN;
VAR
result: BOOLEAN;
value: LONGINT;
rangeExpression: SyntaxTree.RangeExpression;
BEGIN
IF x IS SyntaxTree.RangeExpression THEN
rangeExpression := x(SyntaxTree.RangeExpression);
result := TRUE;
IF IsIntegerValue(rangeExpression.first, value) & (value # 0) THEN result := FALSE END;
IF IsIntegerValue(rangeExpression.last, value) & (value # MAX(LONGINT)) THEN result := FALSE END;
IF IsIntegerValue(rangeExpression.step, value) & (value # 1) THEN result := FALSE END
ELSE
result := FALSE
END;
RETURN result
END IsStaticallyOpenRange;
PROCEDURE IsStaticRange(x: SyntaxTree.Expression; VAR firstValue, lastValue, stepValue: LONGINT): BOOLEAN;
VAR
result: BOOLEAN;
rangeExpression: SyntaxTree.RangeExpression;
BEGIN
IF x IS SyntaxTree.RangeExpression THEN
rangeExpression := x(SyntaxTree.RangeExpression);
result := TRUE;
IF ~IsIntegerValue(rangeExpression.first, firstValue) THEN result := FALSE END;
IF ~IsIntegerValue(rangeExpression.last, lastValue) THEN result := FALSE END;
IF ~IsIntegerValue(rangeExpression.step, stepValue) THEN result := FALSE END
ELSE
result := FALSE
END;
RETURN result
END IsStaticRange;
PROCEDURE IsTensor(type: SyntaxTree.Type): BOOLEAN;
BEGIN RETURN (type.resolved IS SyntaxTree.MathArrayType) & (type.resolved(SyntaxTree.MathArrayType).form = SyntaxTree.Tensor)
END IsTensor;
PROCEDURE StaticMathArrayLengths(mathArrayType: SyntaxTree.MathArrayType): SyntaxTree.MathArrayExpression;
VAR
result: SyntaxTree.MathArrayExpression;
type: SyntaxTree.Type;
length: LONGINT;
BEGIN
ASSERT(mathArrayType.form = SyntaxTree.Static);
result := SyntaxTree.NewMathArrayExpression(InvalidPosition);
type := mathArrayType;
WHILE type IS SyntaxTree.MathArrayType DO
length := type(SyntaxTree.MathArrayType).staticLength;
result.elements.AddExpression(SyntaxTree.NewIntegerValue(InvalidPosition, length));
type := type(SyntaxTree.MathArrayType).arrayBase.resolved
END
END StaticMathArrayLengths;
PROCEDURE HasAddress(expression: SyntaxTree.Expression): BOOLEAN;
BEGIN
RETURN (expression IS SyntaxTree.SymbolDesignator) OR (expression IS SyntaxTree.ResultDesignator)
OR (expression IS SyntaxTree.IndexDesignator) OR (expression IS SyntaxTree.DereferenceDesignator)
OR (expression IS SyntaxTree.TypeGuardDesignator) OR (expression IS SyntaxTree.StringValue);
END HasAddress;
PROCEDURE IsStaticProcedure*(procedure: SyntaxTree.Procedure): BOOLEAN;
BEGIN
IF procedure.scope IS SyntaxTree.RecordScope THEN
RETURN (procedure.super = NIL) & ((procedure.isFinal) OR (procedure.access * SyntaxTree.Public = {}) & ~procedure.isOverwritten)
ELSE
RETURN TRUE
END;
END IsStaticProcedure;
END FoxSemanticChecker.