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;
 
 
 
© 2017 Turbo Pascal | Privacy Policy