Processing Object Types
Turbo Pascal includes many functions and procedures to process object type declaration. The reason is in the complexity of object type. It can contain fields, methods, constructors, destructors, private and public members, static methods, dynamic methods, virtual methods, etc.
Function ProcessObjectTypeDeclaration (TypeIdentifier: PIdentifier): PTypeDefinition;
Type TProc2 = Procedure (MethodIdentifierData: PProcedureIdentifierData; Index: Word);
Var ObjectType, AncestorTypeDefinition: PObjectTypeDefinition;
Saved_LastPointerToTypeDefinitionOffset: Word;
Last_UnitW30: Word;
UnitIdentifierData: PUnitIdentifierData;
AncestorUnitTypeOffset: TUnitOffsets;
ObjectDataType: TIntegerTypeSet;
Data_W02, Data_W10, Data_W14, Data_W1E, Data_W20, Data_W22, Data_W24: Word;
begin
Saved_LastPointerToTypeDefinitionOffset := LastPointerToTypeDefinitionOffset;
If CurrentProcedureIdentifier <> 0 then Error (LocalObjectTypesAreNotAllowed);
GetNextToken;
ObjectType := CreateTypeDefinition (SizeOf (TObjectTypeDefinition), 0, [], btObject);
With ObjectType^ do
begin
TypeIdentifierOffset := Ofs (TypeIdentifier^);
W1A := 0;
W1C := 0;
end;
Last_UnitW30 := 0;
If (SourceType <> stUnitImplementation) or (LocalDebugSymbols in ModuleCompilerSwitches) then
begin
Last_UnitW30 := PUnitHeader (Ptr (Seg (ObjectType^), 0))^.W30;
PUnitHeader (Ptr (Seg (ObjectType^), 0))^.W30 := Ofs (ObjectType^);
end;
ObjectType^.W18 := Last_UnitW30;
CurrentRecordOrObjectTypeDefinitionOffset := Ofs (ObjectType^);
If CheckAndGetNextToken (Token_LeftParenthesis) then
begin
AncestorTypeDefinition := PObjectTypeDefinition (ExpectTypeIdentifier);
If AncestorTypeDefinition^.BaseType <> btObject then Error (ObjectTypeExpected);
ExpectTokenAndGetNext (Token_RightParenthesis);
ObjectDataType := [];
UnitIdentifierData := Ptr (Seg (AncestorTypeDefinition^), AncestorTypeDefinition^.W24);
Data_W24 := UnitIdentifierData^.UnitSegment;
Data_W22 := AncestorTypeDefinition^.W22;
UnitIdentifierData := Ptr (Seg (AncestorTypeDefinition^), AncestorTypeDefinition^.W20);
Data_W20 := UnitIdentifierData^.UnitSegment;
Data_W1E := AncestorTypeDefinition^.W1E;
Data_W14 := AncestorTypeDefinition^.OffsetOf_VMT_Offset;
Data_W10 := AncestorTypeDefinition^.VMT_Size;
Data_W02 := AncestorTypeDefinition^.Size;
GetTypeAndUnitIdentifierOffsets (Pointer (AncestorTypeDefinition), AncestorUnitTypeOffset);
end else begin
ObjectDataType := [];
Data_W24 := SystemUnitSegment;
Data_W22 := $0118;
Data_W20 := SystemUnitSegment;
Data_W1E := $0110;
Data_W14 := $FFFF;
Data_W10 := $0000;
Data_W02 := $0000;
AncestorUnitTypeOffset.UnitAndTypeOffset := 0;
end;
With ObjectType^ do
begin
DataType := ObjectDataType;
AncestorTypeOffset := AncestorUnitTypeOffset;
Size := Data_W02;
VMT_Size := Data_W10;
OffsetOf_VMT_Offset := Data_W14;
W1E := Data_W1E;
W20 := UnitIdentifierDataOffset (Data_W20);
W22 := Data_W22;
W24 := UnitIdentifierDataOffset (Data_W24);
W0A := 0;
W1A := 0;
W1C := 0;
VMT_TypedConstantsBlockRecordOffset := $FFFF;
W16 := $FFFF;
FieldsListOffset := SymbolTable [stMain].NextRecordOffset;
end;
OffsetToNextMemberOffset := Ofs (ObjectType^.W0A);
NumberOfDynamicMethods := 0;
CreateSymbolTable (8);
ProcessSectionOfMembers;
Repeat
If CheckAndGetNextToken (Token_PUBLIC) then PrivateFlagMask := $00 else
If CheckAndGetNextToken (Token_PRIVATE) then PrivateFlagMask := $80 else Break;
ProcessSectionOfMembers;
until False;
PrivateFlagMask := $00;
ExpectTokenAndGetNext (Token_END);
CreateVMT;
CurrentRecordOrObjectTypeDefinitionOffset := 0;
LastPointerToTypeDefinitionOffset := Saved_LastPointerToTypeDefinitionOffset;
ProcessObjectTypeDeclaration := ObjectType;
end;Dynamic methods need Dynamic Method Table (DMT) and virtual methods need Virtual Method Table (VMT). Few procedures take care for this.
Procedure CreateVMT;
Var VMT: PVMT;
begin
With ObjectType^ do If VMT_Size <> 0 then
begin
If OffsetOf_VMT_Offset = $FFFF then
begin
OffsetOf_VMT_Offset := Size;
Inc (Size, 2);
end;
CreateDMT;
VMT := IncreaseSymbolTable (stTypedConstants, VMT_Size);
With VMT^.Header do
begin
SizeOfObjectInstance := Size;
NegativeSizeOfObjectInstance := - Size;
DMT_Offset := 0;
AlwaysZero := 0;
end;
FillChar (VMT^.VirtualMethodPointer [0], VMT_Size - SizeOf (TVMTHeader), $FF);
SetOffsetToDMT (0, Ofs (VMT^.Header.DMT_Offset));
Create_VMT_Entries;
VMT_TypedConstantsBlockRecordOffset := SymbolTable [stTypedConstantsBlocks].UsedSize;
CreateTypedConstantsBlockRecord;
end;
end;
Procedure SetOffsetToDMT (B: Byte; TypedConstantOffset: Word);
Label AncestorType;
Var ObjectTypeDefinition: PObjectTypeDefinition;
begin
ObjectTypeDefinition := ObjectType;
If B <> 0 then GoTo AncestorType;
While ObjectTypeDefinition^.W16 = $FFFF do
begin
AncestorType:
If ObjectTypeDefinition^.AncestorTypeOffset.TypeOffset = 0 then Exit;
ObjectTypeDefinition := PointerFromOffsets (ObjectTypeDefinition^.AncestorTypeOffset);
end;
AddReferenceRecordForTypedConstant (Seg (ObjectTypeDefinition^), ObjectTypeDefinition^.W16,
[rfDataSegment, rfConstant, rfOffset], 0, TypedConstantOffset);
end;
Procedure Create_VMT_Entries;
Var ObjectTypeDefinition: PObjectTypeDefinition;
begin
Repeat
ObjectTypeDefinition := ObjectType;
CallProcedureForEachMethod (ObjectTypeDefinition, Create_VMT_Entry, 0);
If ObjectTypeDefinition^.AncestorTypeOffset.TypeOffset = 0 then Break;
ObjectTypeDefinition := PointerFromOffsets (ObjectTypeDefinition^.AncestorTypeOffset);
until False;
end;
Procedure Create_VMT_Entry (MethodIdentifierData: PProcedureIdentifierData; Index: Word); Far;
begin
With MethodIdentifierData^ do If (W8 << 0) and not (pfDynamic in Flags) and
(Word (Ptr (SymbolTable [stTypedConstants].Segment, LastTypedConstantsSize + W8)^) <> 0) then
begin
Word (Ptr (SymbolTable [stTypedConstants].Segment, LastTypedConstantsSize + W8)^) := 0;
Word (Ptr (SymbolTable [stTypedConstants].Segment, LastTypedConstantsSize + W8 + 2)^) := 0;
AddReferenceRecordForTypedConstant (Seg (MethodIdentifierData^), ProceduresRecordOffset,
[rfSegment, rfOffset], 0, LastTypedConstantsSize + W8);
end;
end;
Procedure Create_DMT_Entries;
Var ObjectTypeDefinition: PObjectTypeDefinition;
begin
Repeat
ObjectTypeDefinition := ObjectType;
CallProcedureForEachMethod (ObjectTypeDefinition, Create_DMT_Entry, 0);
If ObjectTypeDefinition^.AncestorTypeOffset.TypeOffset = 0 then Break;
ObjectTypeDefinition := PointerFromOffsets (ObjectTypeDefinition^.AncestorTypeOffset);
until False;
end;
Procedure Create_DMT_Entry (MethodIdentifierData: PProcedureIdentifierData; Index: Word); Far;
begin
With MethodIdentifierData^ do If pfDynamic in Flags then
begin
Word (Ptr (SymbolTable [stTypedConstants].Segment, CurrentTypedConstantValueOffset + DynamicMethodCounter * 2)^) := W8;
AddReferenceRecordForTypedConstant (Seg (MethodIdentifierData^), ProceduresRecordOffset,
[rfSegment, rfOffset], 0, CurrentTypedConstantValueOffset + NumberOfDynamicMethods * 6);
Inc (DynamicMethodCounter);
end;
end;
Procedure CreateDMT;
Var DMT: PDMT;
begin
If NumberOfDynamicMethods <> 0 then
begin
DMT := IncreaseSymbolTable (stTypedConstants, NumberOfDynamicMethods * (SizeOf (Integer) + SizeOf (Pointer)) +
SizeOf (TDMTHeader));
With DMT^.Header do
begin
Parent_DMT_Offset := 0;
CachedIndex := 0;
CachedEntryOffset := 0;
EntryCount := NumberOfDynamicMethods;
end;
CurrentTypedConstantValueOffset := Ofs (DMT^.DynamicMethodIndexTable [0]);
FillChar (DMT^.DynamicMethodIndexTable [0], NumberOfDynamicMethods * (SizeOf (Integer) + SizeOf (Pointer)), 0);
SetOffsetToDMT (1, Ofs (DMT^.Header.Parent_DMT_Offset));
Create_DMT_Entries;
ObjectType^.W16 := SymbolTable [stTypedConstantsBlocks].UsedSize;
CreateTypedConstantsBlockRecord;
end;
end;This procedure goes through all object’s methods and calls specified procedure for each method. It is used to check for unique index for dynamic methods and to create entries in DMT and VMT.
Procedure CallProcedureForEachMethod (ObjectTypeDefinition: PObjectTypeDefinition; Proc2: TProc2; DynamicMethodIndex: Word);
Var ObjectIdentifier: PIdentifier;
ObjectIdentifierOfs: Word absolute ObjectIdentifier;
VariableIdentifierData: PVariableIdentifierData;
MethodIdentifierData: PProcedureIdentifierData absolute VariableIdentifierData;
begin
DynamicMethodCounter := 0;
ObjectIdentifier := Pointer (ObjectTypeDefinition);
ObjectIdentifierOfs := ObjectTypeDefinition^.W0A;
While ObjectIdentifierOfs <> 0 do
begin
VariableIdentifierData := PVariableIdentifierData (PChar (ObjectIdentifier) + ObjectIdentifier^.Name.Len + 4);
Case TToken (Ord (ObjectIdentifier^.Token) and $7F) of
Token_VariableIdentifier: ObjectIdentifierOfs := VariableIdentifierData^.W5;
else begin
Proc2 (MethodIdentifierData, DynamicMethodIndex);
ObjectIdentifierOfs := MethodIdentifierData^.ProcedureTypeDefinition.W06_;
end;
end;
end;
end;This procedure processes members of Turbo Pascal object: Private and Public directives, fields, methods (procedures and functions), constructors and destructors.
Procedure ProcessSectionOfMembers;
Var MethodsDeclared: Boolean;
begin
MethodsDeclared := False;
Repeat
CheckIfDirecive (_PUBLIC, Token_PUBLIC);
CheckIfDirecive (_PRIVATE, Token_PRIVATE);
Case Token of
Token_PROCEDURE,
Token_FUNCTION: begin
ProcessMethodDeclaration (Token);
MethodsDeclared := True;
Continue;
end;
Token_CONSTRUCTOR,
Token_DESTRUCTOR: begin
ProcessMethodDeclaration (Token);
MethodsDeclared := True;
Continue;
With PObjectTypeDefinition (Ptr (SymbolTable [stMain].Segment,
CurrentRecordOrObjectTypeDefinitionOffset))^ do
If VMT_Size = 0 then VMT_Size := 8;
end;
end;
If MethodsDeclared then Exit;
Case Token of
Token_PUBLIC,
Token_PRIVATE,
Token_END: Exit;
end;
ProcessCommaSeparatedFieldsAndType;
CalculateVariableOffsets;
ExpectTokenAndGetNext (Token_Semicolon);
MethodsDeclared := False;
until False;
end;
Procedure ProcessMethodDeclaration (MethodToken: TToken);
Var MethodIdentifierOffset: Word;
MethodIdentifier: PIdentifier;
MethodIdentifierData: PProcedureIdentifierData;
MethodIdentifierToken: TToken;
MethodType: PProcedureTypeDefinition;
AncestorMethodIdentifierData: PProcedureIdentifierData;
begin
GetNextToken;
ExpectIdentifier;
If CurrentIdentifierDeclaredInCurrentScope (MethodIdentifierOffset, Pointer (MethodIdentifierData),
MethodIdentifierToken) then
begin
If MethodIdentifierToken <> Token_ProcedureIdentifier then Error (DuplicateIdentifier);
If Ptr (Seg (MethodIdentifierData^), MethodIdentifierData^.OuterBlockProcedureIdentifier) =
Ptr (SymbolTable [stMain].Segment, CurrentRecordOrObjectTypeDefinitionOffset) then Error (DuplicateIdentifier);
AncestorMethodIdentifierData := MethodIdentifierData;
end else AncestorMethodIdentifierData := nil;
MethodIdentifierData := StoreCurrentIdentifierToSymbolTable (CurrentScopeIdentifierTableAddress, 10, MethodIdentifier);
GetNextToken;
MethodIdentifier^.Token := TToken (Ord (Token_ProcedureIdentifier) or PrivateFlagMask);
MethodIdentifierData^.OuterBlockProcedureIdentifier := CurrentRecordOrObjectTypeDefinitionOffset;
MethodIdentifierData^.LocalIdentifiersList := SymbolTable [stTemporary].UsedSize;
Word (Ptr (Seg (MethodIdentifierData^), OffsetToNextMemberOffset)^) := Ofs (MethodIdentifier^);
OffsetToNextMemberOffset := Ofs (MethodIdentifierData^.ProcedureTypeDefinition.W06_);
CreateProcedureRecord (MethodIdentifier, MethodIdentifierData);
Case MethodToken of
Token_CONSTRUCTOR: MethodIdentifierData^.Flags := [pfConstructor, pfMethod, pfFar];
Token_DESTRUCTOR : MethodIdentifierData^.Flags := [pfDestructor, pfMethod, pfFar];
else MethodIdentifierData^.Flags := [ pfMethod, pfFar];
end;
MethodType := ProcessProcedureHeader (MethodToken);
MethodType^.Size := 8;
ExpectTokenAndGetNext (Token_Semicolon);
If (AncestorMethodIdentifierData = nil) or (AncestorMethodIdentifierData^.W8 = 0) then
CheckIfVirtualMethod else
CheckOverridenVirtualMethod;
end;
Procedure CheckIfVirtualMethod;
Var ObjectTypeDefinition: PObjectTypeDefinition;
DynamicMethodIndex: Word;
begin
If CompareIdentifierToDirectiveAndGetNextToken (_VIRTUAL) then
begin
ObjectTypeDefinition := Ptr (SymbolTable [stMain].Segment, CurrentRecordOrObjectTypeDefinitionOffset);
With ObjectTypeDefinition^ do If VMT_Size = 0 then VMT_Size := SizeOf (TVMTHeader);
If pfConstructor in MethodIdentifierData^.Flags then Error (VirtualConstructorsAreNotAllowed);
Case Token of
Token_Semicolon: begin
DynamicMethodIndex := ExpectIntegerConstant;
If DynamicMethodIndex = 0 then Error (DuplicateDynamicMethodIndex);
Repeat
CallProcedureForEachMethod (ObjectTypeDefinition,
CheckIfUniqueDynamicMethodIndex,
DynamicMethodIndex);
If ObjectTypeDefinition^.AncestorTypeOffset.TypeOffset = 0 then Break;
ObjectTypeDefinition := PointerFromOffsets (ObjectTypeDefinition^.AncestorTypeOffset);
until False;
MethodIdentifierData^.W8 := DynamicMethodIndex;
Include (MethodIdentifierData^.Flags, pfDynamic);
end;
else begin
MethodIdentifierData^.W8 := ObjectTypeDefinition^.VMT_Size;
Inc (ObjectTypeDefinition^.VMT_Size, SizeOf (Pointer));
end;
end;
ExpectTokenAndGetNext (Token_Semicolon);
end else MethodIdentifierData^.W8 := 0;
end;
Procedure CheckOverridenVirtualMethod;
Var DynamicMethodIndex: Word;
begin
If CompareIdentifierToDirectiveAndGetNextToken (_VIRTUAL) then
begin
If pfDynamic in AncestorMethodIdentifierData^.Flags then
begin
If Token = Token_Semicolon then Error (IntegerConstantExpected);
DynamicMethodIndex := ExpectIntegerConstant;
If DynamicMethodIndex <> AncestorMethodIdentifierData^.W8 then
Error (HeaderDoesNotMatchPreviousDefinition);
If (AncestorMethodIdentifierData^.Flags * [pfConstructor, pfDestructor]) <>
(MethodIdentifierData^.Flags * [pfConstructor, pfDestructor]) then
Error (HeaderDoesNotMatchPreviousDefinition);
If not CheckProcedureTypeCompatibility (@MethodIdentifierData^.ProcedureTypeDefinition,
@AncestorMethodIdentifierData^.ProcedureTypeDefinition) then
Error (HeaderDoesNotMatchPreviousDefinition);
ExpectTokenAndGetNext (Token_Semicolon);
MethodIdentifierData^.W8 := DynamicMethodIndex;
MethodIdentifierData^.Flags :=
MethodIdentifierData^.Flags + AncestorMethodIdentifierData^.Flags * [pfDynamic, pf0100];
end;
end else Error (VIRTUAL_Expected);
end;Dynamic method indexes need to be unique.
Procedure CheckIfUniqueDynamicMethodIndex (MethodIdentifierData: PProcedureIdentifierData; Index: Word); Far;
begin
With MethodIdentifierData^ do
If pfDynamic in Flags then If Index = W8 then Error (DuplicateDynamicMethodIndex);
end;