(* This file is distributed under the Lesser GNU General Public License (see the file COPYING.LGPL) with the following modification: As a special exception, the copyright holders of this library give you permission to link this library with independent modules to produce an executable, regardless of the license terms of these independent modules, and to copy and distribute the resulting executable under terms of your choice, provided that you also meet, for each linked independent module, the terms and conditions of the license of that module. An independent module is a module which is not derived from or based on this library. If you modify this library, you may extend this exception to your version of the library, but you are not obligated to do so. If you do not wish to do so, delete this exception statement from your version. If you didn't receive a copy of the file COPYING.LGPL, contact: Free Software Foundation, Inc., 675 Mass Ave Cambridge, MA 02139 USA *) unit JitTypes; {$mode objfpc}{$H+} {$ModeSwitch advancedrecords} {$ModeSwitch typehelpers} {.$Inline off} {..$DEFINE JIT_REFCNT_DEBUG} interface uses {$IFDEF JIT_REFCNT_DEBUG} LazLogger, {$ENDIF} Classes, SysUtils, TypInfo, fgl, JitHelper, JitRttiWriter; type { JitTypeParserException } JitTypeParserException = class(Exception) private FErrorPos: Integer; FErrorToken: String; public constructor Create(APos: Integer; const AToken, msg: string); property ErrorPos: Integer read FErrorPos; property ErrorToken: String read FErrorToken; end; JitTypeParserExceptionTypeNotFound = class(JitTypeParserException) end; JitTypeParserExceptionSyntaxError = class(JitTypeParserException) end; (* TRefCountedJitReference By default, when TJitType and TJitCreator are destroyed, they will free the TypeInfo and JitClass that they provided. In order to be able to use this data past the creators life time, one can obtain a LockReference from the creator. The TJitType and TJitCreator can still be destroyed, but the TypeInfo and JitClass will be kept, until all locks have been released. *) { TRefCountedJitReference } TRefCountedJitReference = class strict private FRefCount: Integer; protected procedure DoRefCountZero; virtual; procedure DoBeforeDecRefCount; virtual; procedure IncRefCount; inline; procedure DecRefCount; inline; public constructor Create; destructor Destroy; override; procedure ReleaseLock; inline; property RefCount: Integer read FRefCount; end; { TRefCountedJitNestedReference } TRefCountedJitNestedReference = class(TRefCountedJitReference) protected type { TRefCountedJitReferenceList } TRefCountedJitReferenceList = class(specialize TFPGList) public procedure ClearList; end; strict private (* The list can contain duplicates / This way we know when this list has more that one ref to the same object *) FNestedReferrences: TRefCountedJitReferenceList; private class var FLastTag: QWord; private FInGetCircularRefCount, FOnlyHasCircularNestedRefs: ByteBool; // All refs start with a none circular ref FTag: QWord; function HasExternalCircularRefCount(ARefObj: TRefCountedJitReference; ATag: QWord; AnHasExternRefInCallPath: Boolean): Boolean; function GetCircularRefCount(ARefObj: TRefCountedJitReference; ATag: QWord; AnHasExternRefInCallPath: Boolean; out AnFoundExternRef: Boolean): integer; protected procedure DoRefCountZero; override; procedure DoBeforeDecRefCount; override; property NestedReferrences: TRefCountedJitReferenceList read FNestedReferrences; function NestedCount: integer; virtual; function GetNested(AnIndex: integer): TRefCountedJitReference; virtual; property Nested[AnIndex: integer]: TRefCountedJitReference read GetNested; public procedure AddToList(AReference: TRefCountedJitReference); overload; // RemoveFromList: will remove ONE entry of the given instance procedure RemoveFromList(AReference: TRefCountedJitReference); procedure ClearList; virtual; public destructor Destroy; override; end; { TFreeNotifyingObject } TFreeNotifyingObject = class private type { TMethodComp } TMethodComp = record m: TMethod; class operator = (a, b: TMethodComp): Boolean; end; TNotifyList = specialize TFPGList; private FFreeNotificationList: TNotifyList; public destructor Destroy; override; procedure AddFreeNotification(ANotification: TNotifyEvent); procedure RemoveFreeNotification(ANotification: TNotifyEvent); end; { TReferenceAbleJitClass } TReferenceAbleJitClass = class(TFreeNotifyingObject) protected function GetLockReferenceInc: TRefCountedJitReference; virtual; // forwarders must overwrite this method, to avoid double inc function GetLockReferenceObj: TRefCountedJitReference; virtual; public (* LockReference - returns nil, if no ref needed - returned referrence will have RefCount already increased *) property LockReference: TRefCountedJitReference read GetLockReferenceInc; end; { TJitClassCreatorBase } TJitClassCreatorBase = class(TReferenceAbleJitClass) protected FClassUnit: String; function GetTypeInfo: PTypeInfo; virtual; abstract; function GetJitClass: TClass; virtual; abstract; public property TypeInfo: PTypeInfo read GetTypeInfo; property ClassUnit: String read FClassUnit; // write SetClassUnit; end; TJitTypeLibrary = class; { TJitType } TJitType = class(TReferenceAbleJitClass) strict private FTypeLibrary: TJitTypeLibrary; private FOwnedByLibrary: Boolean; FTypeName: String; FUnitName: String; procedure DoTypeLibFreed(Sender: TObject); procedure SetTypeLibrary(AValue: TJitTypeLibrary); protected function GetTypeInfo: PTypeInfo; virtual; function IsConstTypeInfo: Boolean; virtual; // TypeInfo must not be freed function GetResolvedTypeName: String; property TypeLibrary: TJitTypeLibrary read FTypeLibrary write SetTypeLibrary; public constructor Create(ATypeName: String; ATypeLibrary: TJitTypeLibrary = nil); constructor Create(ATypeName, AUnitName: String; ATypeLibrary: TJitTypeLibrary = nil); destructor Destroy; override; property TypeName: String read FTypeName; property ResolvedTypeName: String read GetResolvedTypeName; // un-aliased property TypeInfo: PTypeInfo read GetTypeInfo; property UnitName: String read FUnitName write FUnitName; // ignored by alias property OwnedByLibrary: Boolean read FOwnedByLibrary; end; { TJitDeclarationParser } TJitParserTkKind = ( ptNone, ptError, ptIdent, ptNum, ptChar, ptEmptyString, ptRoundOpen, ptRoundClose, ptSquareOpen, ptSquareClose, // brackens ptColon, ptComma, ptSemicolon, ptEqual, ptSymbol, ptDot, ptDotDot, kwSet, kwArray, kwOf, kwClass, kwObject, kwString, kwRecord, kwFunction, kwProcedure, kwProperty, kwPublished, kwPublic, kwProtected, kwPrivate, kwEnd, kwVar, kwConst, kwOut, kwConstRef, ptEOT); TJitParserTkKinds = set of TJitParserTkKind; PJitDeclarationParser = ^TJitDeclarationParser; TCheckSectionEndProc = function(AParser: PJitDeclarationParser): boolean of object; TJitDeclarationParser = record private type TJitDeclarationParserData = record FCurToken: PChar; FCurTokenLen: Integer; FCurTokenKind: TJitParserTkKind; end; TParseContext = (pcNone, pcFuncParamStart, pcOfExpexted); private FStartPos: PChar; FCheckSectionEndProc: TCheckSectionEndProc; FSavePoint: TJitDeclarationParserData; DAT: TJitDeclarationParserData; procedure SkipWhiteSpace; inline; public constructor Create(ATokenStart: PChar); function CurPos: Integer; function IsBeforeEOT: Boolean; // Next will be IsBeforeEOT function IsBeforeEotOrSectionEnd: Boolean; // at IsBeforeEOT, ";" or "end" function Next(AContext: TParseContext = pcNone): TJitParserTkKind; function CurrentToken: String; function CurrentTokenAsNum(out IsQWord: Boolean): Int64; function CurrentTokenRaw: String; inline; // with escaping & for idents function NextToken: String; inline; function PeekKind(AContext: TParseContext = pcNone): TJitParserTkKind; inline; function PeekTokenRaw: String; // GetQualifiedIdent: Expands CurrentToken to full ident procedure GetQualifiedIdent(out APath, AnIdent: String); // for unit.type procedure GetQualifiedIdent(out APath, AnIdent1, AnIdent2: String); // for unit.enumtype.member procedure SavePosition; procedure RestorePosition; property CurrentKind: TJitParserTkKind read DAT.FCurTokenKind; property CheckSectionEndProc: TCheckSectionEndProc read FCheckSectionEndProc write FCheckSectionEndProc; end; TJitTypeInfoParseFlag = (pfAllowProcName, pfAlwaysAsMethod); TJitTypeInfoParseFlags = set of TJitTypeInfoParseFlag; { TJitTypeInfo } TJitTypeInfo = class(TJitType) private type { TRefCountedTypeInfo } TRefCountedTypeInfo = class(TRefCountedJitNestedReference) private FTypeInfo: PTypeInfo; function IndexOf(ATypeInfo: PTypeInfo): integer; procedure AddToList(ATypeInfo: TJitType); overload; // RemoveFromList: will remove ONE entry of this procedure RemoveFromList(ATypeInfo: PTypeInfo); procedure SetTypeInfo(ATypeInfo: PTypeInfo); protected procedure DoRefCountZero; override; property TypeInfo: PTypeInfo read FTypeInfo; public constructor Create(ATypeInfo: PTypeInfo); end; private FIsConstTypeInfo: Boolean; FTypeInfo: PTypeInfo; // use Set[Const]FTypeInfo for write access => so Ref is updated too FRefCountedTypeInfo: TRefCountedTypeInfo; // created on request => use RefCountedTypeInfo() FDeclaration: String; FParseFlags: TJitTypeInfoParseFlags; FIsInParseFromDeclaration: Boolean; procedure SetFTypeInfo(AValue: PTypeInfo); procedure SetConstFTypeInfo(AValue: PTypeInfo); function RefCountedTypeInfo: TRefCountedTypeInfo; inline; protected procedure ParseFromDeclaration(AParser: PJitDeclarationParser = nil); function GetTypeInfo: PTypeInfo; override; function GetLockReferenceObj: TRefCountedJitReference; override; function IsConstTypeInfo: Boolean; override; public constructor Create(ATypeName, ADeclaration, AUnitName: String; ATypeLibrary: TJitTypeLibrary = nil; AParseFlags: TJitTypeInfoParseFlags = []); constructor Create(ATypeName, ADeclaration: String; ATypeLibrary: TJitTypeLibrary = nil; AParseFlags: TJitTypeInfoParseFlags = []); constructor Create(ATypeName: String; ATypeInfo: PTypeInfo; ATypeLibrary: TJitTypeLibrary = nil); destructor Destroy; override; property Declaration: String read FDeclaration; end; TJitTypeClassBase = class abstract (TJitType) protected function GetJitClass: TClass; virtual; abstract; public property JitClass: TClass read GetJitClass; end; { TJitTypeClass } TJitTypeClass = class(TJitTypeClassBase) private FClass: TClass; protected function GetTypeInfo: PTypeInfo; override; function GetJitClass: TClass; override; public // UnitName defaults to AClass.UnitName constructor Create(ATypeName: String; AClass: TClass; ATypeLibrary: TJitTypeLibrary = nil); constructor Create(ATypeName, AUnitName: String; AClass: TClass; ATypeLibrary: TJitTypeLibrary = nil); end; { TJitTypeJitClass } TJitTypeJitClass = class(TJitTypeClassBase) private FJitClassCreator: TJitClassCreatorBase; FOwnJitCreator: Boolean; procedure DoCreatorFreed(Sender: TObject); protected function GetTypeInfo: PTypeInfo; override; function GetJitClass: TClass; override; function GetLockReferenceInc: TRefCountedJitReference; override; function IsConstTypeInfo: Boolean; override; public // UnitName defaults to AJitClassCreator.ClassUnit constructor Create(ATypeName: String; AJitClassCreator: TJitClassCreatorBase; ATypeLibrary: TJitTypeLibrary = nil; ATakeOwnerShip: Boolean = False); constructor Create(ATypeName, AUnitName: String; AJitClassCreator: TJitClassCreatorBase; ATypeLibrary: TJitTypeLibrary = nil; ATakeOwnerShip: Boolean = False); destructor Destroy; override; property JitClassCreator: TJitClassCreatorBase read FJitClassCreator; property OwnJitCreator: Boolean read FOwnJitCreator write FOwnJitCreator; end; { TJitTypeAlias } TJitTypeAlias = class(TJitType) private FRealType: TJitType; FRealTypeName: String; FInGetRealType: Boolean; procedure DoRealTypeFreed(Sender: TObject); function GetRealType: TJitType; protected function GetTypeInfo: PTypeInfo; override; function GetLockReferenceInc: TRefCountedJitReference; override; function IsConstTypeInfo: Boolean; override; function GetResolvedTypeName: String; public constructor Create(ATypeName, ARealTypeName: String; ATypeLibrary: TJitTypeLibrary = nil); constructor Create(ATypeName: String; ARealType: TJitType; ATypeLibrary: TJitTypeLibrary = nil); destructor Destroy; override; end; TTypeSearchOption = ( tsoOnlyUnit // Search only in the given unit. Otherwise search the unit first, then all others ); TTypeSearchOptions = set of TTypeSearchOption; { TJitTypeLibrary } TJitTypeLibrary = class(TFreeNotifyingObject) private type TTypeMap = specialize TFPGMap; procedure DoTypeFreed(Sender: TObject); private FAllowDuplicates: Boolean; FTypeMap: TTypeMap; function GetTypes(AName: String): TJitType; procedure SetAllowDuplicates(AValue: Boolean); protected function IndexOf(ATypeName, AnUnitName: String): Integer; overload; public constructor Create; destructor Destroy; override; function AddType(AType: TJitType; ATakeOwnerShip: Boolean = True): TJitType; (* AddType: AddType may create an alias, if the Declaration is a single existing identifier. If a new TJitTypeInfo should be created regardless => use AForceNewJitTypeInfo *) function AddType(ATypeName, ADeclaration: String; AForceNewJitTypeInfo: Boolean = False): TJitType; overload; function AddType(ATypeName, ADeclaration, AUnitName: String; AForceNewJitTypeInfo: Boolean = False): TJitType; overload; (* AddClass: AUnitName defaults to AClass.UnitName. It can be overriden, this should be done with an empty name to make the type match any unit in IndexOf *) function AddClass(ATypeName: String; AClass: TClass): TJitType; overload; function AddClass(ATypeName, AUnitName: String; AClass: TClass): TJitType; overload; function AddJitClass(ATypeName: String; AJitClassCreator: TJitClassCreatorBase; ATakeCreatorOwnerShip: Boolean = False): TJitType; overload; function AddAlias(ATypeName, ARealTypeName: String): TJitType; overload; procedure Remove(ATypeName: String; AnUnitName: String = ''); procedure Clear; function FindType(const AName: String; AnUnitName: String = ''; ASearchOptions: TTypeSearchOptions = []): TJitType; function FindTypeForEnumElem(const AnEnumElem: String; AnUnitName: String = ''; ASearchOptions: TTypeSearchOptions = []): TJitType; function FindTypeForEnumElem(const AnEnumElem: String; out AnEnumVal: Integer; AnUnitName: String = ''; ASearchOptions: TTypeSearchOptions = []): TJitType; property Types[AName: String]: TJitType read GetTypes; default; property AllowDuplicates: Boolean read FAllowDuplicates write SetAllowDuplicates; end; function TypeInfoByName(ATypeName: String): PTypeInfo; function TrimDeclaration(ADecl: String): String; implementation function TypeInfoByName(ATypeName: String): PTypeInfo; begin case lowercase(ATypeName) of 'byte': Result := TypeInfo(Byte); 'word': Result := TypeInfo(Word); 'longword': Result := TypeInfo(LongWord); 'qword': Result := TypeInfo(QWord); 'shortint': Result := TypeInfo(ShortInt); 'smallint': Result := TypeInfo(SmallInt); 'longint': Result := TypeInfo(LongInt); 'int64': Result := TypeInfo(Int64); 'single': Result := TypeInfo(Single); 'double': Result := TypeInfo(Double); 'real': Result := TypeInfo(Real); 'extended': Result := TypeInfo(Extended); 'boolean': Result := TypeInfo(Boolean); 'bytebool': Result := TypeInfo(ByteBool); 'wordbool': Result := TypeInfo(WordBool); 'longbool': Result := TypeInfo(LongBool); 'qwordbool': Result := TypeInfo(QWordBool); 'ansistring': Result := TypeInfo(AnsiString); 'unicodestring': Result := TypeInfo(UnicodeString); 'widestring': Result := TypeInfo(WideString); 'shortstring': Result := TypeInfo(shortstring); 'char': Result := TypeInfo(Char); 'widechar': Result := TypeInfo(WideChar); 'pointer': Result := TypeInfo(pointer); else Result := nil; end; end; function TrimDeclaration(ADecl: String): String; Const WhiteSpace = [#0..' ', ';']; var Ofs, Len: integer; begin len := Length(ADecl); while (Len>0) and (ADecl[Len] in WhiteSpace) do dec(Len); Ofs := 1; while (Ofs<=Len) and (ADecl[Ofs] in WhiteSpace) do Inc(Ofs); result := Copy(ADecl, Ofs, 1 + Len - Ofs); end; { JitTypeParserException } constructor JitTypeParserException.Create(APos: Integer; const AToken, msg: string); begin inherited Create(msg); FErrorPos := APos; FErrorToken := AToken; end; { TRefCountedJitNestedReference.TRefCountedJitReferenceList } procedure TRefCountedJitNestedReference.TRefCountedJitReferenceList.ClearList; var i: Integer; begin for i := 0 to Count - 1 do Items[i].ReleaseLock; Clear; end; { TFreeNotifyingObject.TMethodComp } class operator TFreeNotifyingObject.TMethodComp. = (a, b: TMethodComp): Boolean; begin result := (a.m.Code = b.m.Code) and (a.m.Data = b.m.Data); end; { TRefCountedJitReference } procedure TRefCountedJitReference.DoRefCountZero; begin // end; procedure TRefCountedJitReference.DoBeforeDecRefCount; begin // end; constructor TRefCountedJitReference.Create; begin FRefCount := 1; end; destructor TRefCountedJitReference.Destroy; begin {$IFDEF JIT_REFCNT_DEBUG} debuglnEnter(['> TRefCountedJitReference.Destroy ',dbgs(self),' ' ]); try {$ENDIF} if FRefCount > 0 then raise exception.Create('destroy while referrenced'); DoRefCountZero; inherited Destroy; {$IFDEF JIT_REFCNT_DEBUG} finally debuglnExit(['< TRefCountedJitReference.Destroy ',dbgs(self) ]); end; {$ENDIF} end; procedure TRefCountedJitReference.IncRefCount; begin inc(FRefCount); end; procedure TRefCountedJitReference.DecRefCount; begin DoBeforeDecRefCount; dec(FRefCount); if FRefCount = 0 then Destroy; end; procedure TRefCountedJitReference.ReleaseLock; begin DecRefCount; end; { TRefCountedJitNestedReference } function TRefCountedJitNestedReference.HasExternalCircularRefCount( ARefObj: TRefCountedJitReference; ATag: QWord; AnHasExternRefInCallPath: Boolean ): Boolean; var i: Integer; n: TRefCountedJitReference; begin {$IFDEF JIT_REFCNT_DEBUG} debuglnEnter(['> HasExternalCircularRefCount ',dbgs(self),' ', RefCount ]); try {$ENDIF} // Once the caller itself has no external refs (i.e. has only circular ones), // the search can stop, as soon as any ONE circle with external has been found Result := not FOnlyHasCircularNestedRefs; if FInGetCircularRefCount or (NestedCount = 0) then exit; FInGetCircularRefCount := True; try for i := 0 to NestedCount - 1 do begin n := Nested[i]; if (n is TRefCountedJitNestedReference) and (TRefCountedJitNestedReference(n).FTag <> ATag) // not yet visited then begin if n = ARefObj then begin Result := AnHasExternRefInCallPath; end else if (TRefCountedJitNestedReference(n).FTag <> ATag) then // not yet visited begin TRefCountedJitNestedReference(n).FTag := ATag; Result := TRefCountedJitNestedReference(n).HasExternalCircularRefCount(ARefObj, ATag, AnHasExternRefInCallPath or not FOnlyHasCircularNestedRefs); end; if Result then exit; end; end; finally FInGetCircularRefCount := False; end; {$IFDEF JIT_REFCNT_DEBUG} finally debuglnExit(['< TRefCountedJitNestedReference.HasExternalCircularRefCount ', Result ]); end; {$ENDIF} end; function TRefCountedJitNestedReference.GetCircularRefCount( ARefObj: TRefCountedJitReference; ATag: QWord; AnHasExternRefInCallPath: Boolean; out AnFoundExternRef: Boolean): integer; var i: Integer; n: TRefCountedJitReference; ExtFound: Boolean; begin {$IFDEF JIT_REFCNT_DEBUG} debuglnEnter(['> GetCircularRefCount ',dbgs(Self) , ' //', RefCount, ' Only:', FOnlyHasCircularNestedRefs, ' nestcnt: ', NestedCount, ' ext in path: ', AnHasExternRefInCallPath]); try {$ENDIF} Result := 0; AnHasExternRefInCallPath := AnHasExternRefInCallPath or not FOnlyHasCircularNestedRefs; AnFoundExternRef := AnHasExternRefInCallPath; if FInGetCircularRefCount or (NestedCount = 0) then exit; FInGetCircularRefCount := True; try for i := 0 to NestedCount - 1 do begin n := Nested[i]; if (n is TRefCountedJitNestedReference) then begin if n = ARefObj then begin inc(Result); if AnHasExternRefInCallPath then AnFoundExternRef := True; end else if (TRefCountedJitNestedReference(n).FTag <> ATag) then // not yet visited begin TRefCountedJitNestedReference(n).FTag := ATag; Result := Result + TRefCountedJitNestedReference(n).GetCircularRefCount(ARefObj, ATag, AnHasExternRefInCallPath, ExtFound ); AnFoundExternRef := AnFoundExternRef or ExtFound; end; end; end; finally FInGetCircularRefCount := False; end; {$IFDEF JIT_REFCNT_DEBUG} finally debuglnExit(['< GetCircularRefCount ', Result, ' with ext: ', AnFoundExternRef ]); end; {$ENDIF} end; procedure TRefCountedJitNestedReference.DoRefCountZero; begin inherited DoRefCountZero; ClearList; end; procedure TRefCountedJitNestedReference.DoBeforeDecRefCount; var ExtFound: Boolean; begin {$IFDEF JIT_REFCNT_DEBUG} debuglnEnter(['> DoBeforeDecRefCount ',dbgs(self),' refc ', RefCount, ' Only:', FOnlyHasCircularNestedRefs, ' nestcnt: ', NestedCount , ' SKIP ',FInGetCircularRefCount]); try {$ENDIF} if (RefCount = 1) or FInGetCircularRefCount then exit; {$PUSH}{$R-} inc(FLastTag); if FLastTag = 0 then inc(FLastTag); {$POP} if FOnlyHasCircularNestedRefs then begin ExtFound := HasExternalCircularRefCount(Self, FLastTag, False); {$IFDEF JIT_REFCNT_DEBUG} DebugLn(['has ext: ', ExtFound]); {$ENDIF} end else begin FOnlyHasCircularNestedRefs := True; // pretend FOnlyHasCircularNestedRefs := RefCount - 1 - GetCircularRefCount(Self, FLastTag, False, ExtFound) = 0; {$IFDEF JIT_REFCNT_DEBUG} DebugLn(['Only : ', FOnlyHasCircularNestedRefs, ' has ext: ', ExtFound]); {$ENDIF} end; if not ExtFound then begin // release all refs FInGetCircularRefCount := True; ClearList; end; {$IFDEF JIT_REFCNT_DEBUG} finally debuglnExit(['< DoBeforeDecRefCount ', RefCount ]); end; {$ENDIF} end; function TRefCountedJitNestedReference.NestedCount: integer; begin if FNestedReferrences = nil then Result := 0 else Result := FNestedReferrences.Count; end; function TRefCountedJitNestedReference.GetNested(AnIndex: integer ): TRefCountedJitReference; begin Result := FNestedReferrences[AnIndex]; end; procedure TRefCountedJitNestedReference.AddToList( AReference: TRefCountedJitReference); begin if AReference = nil then exit; if FNestedReferrences = nil then FNestedReferrences := TRefCountedJitReferenceList.Create; FNestedReferrences.Add(AReference); end; procedure TRefCountedJitNestedReference.RemoveFromList( AReference: TRefCountedJitReference); begin if (FNestedReferrences = nil) or (AReference = nil) then exit; FNestedReferrences.Remove(AReference); end; procedure TRefCountedJitNestedReference.ClearList; begin if FNestedReferrences = nil then exit; FNestedReferrences.ClearList; end; destructor TRefCountedJitNestedReference.Destroy; begin inherited Destroy; ClearList; FNestedReferrences.Free; end; { TFreeNotifyingObject } destructor TFreeNotifyingObject.Destroy; var i: Integer; begin if FFreeNotificationList <> nil then begin i := FFreeNotificationList.Count - 1; while i >= 0 do begin TNotifyEvent(FFreeNotificationList[i])(Self); dec(i); if i >= FFreeNotificationList.Count then i := FFreeNotificationList.Count - 1; end; end; inherited Destroy; FreeAndNil(FFreeNotificationList); end; procedure TFreeNotifyingObject.AddFreeNotification(ANotification: TNotifyEvent); begin if FFreeNotificationList = nil then FFreeNotificationList := TNotifyList.Create; FFreeNotificationList.Add(TMethodComp(ANotification)); end; procedure TFreeNotifyingObject.RemoveFreeNotification(ANotification: TNotifyEvent); begin if FFreeNotificationList = nil then exit; FFreeNotificationList.Remove(TMethodComp(ANotification)); end; { TReferenceAbleJitClass } function TReferenceAbleJitClass.GetLockReferenceInc: TRefCountedJitReference; begin Result := GetLockReferenceObj; if Result <> nil then Result.IncRefCount; end; function TReferenceAbleJitClass.GetLockReferenceObj: TRefCountedJitReference; begin Result := nil; end; { TJitType } function TJitType.GetResolvedTypeName: String; begin Result := TypeName; end; procedure TJitType.DoTypeLibFreed(Sender: TObject); begin FTypeLibrary := Nil; end; procedure TJitType.SetTypeLibrary(AValue: TJitTypeLibrary); begin if FTypeLibrary = AValue then Exit; if FTypeLibrary <> nil then FTypeLibrary.RemoveFreeNotification(@DoTypeLibFreed); FTypeLibrary := AValue; if FTypeLibrary <> nil then FTypeLibrary.AddFreeNotification(@DoTypeLibFreed); end; function TJitType.GetTypeInfo: PTypeInfo; begin Result := nil; end; function TJitType.IsConstTypeInfo: Boolean; begin Result := True; end; constructor TJitType.Create(ATypeName: String; ATypeLibrary: TJitTypeLibrary); begin FTypeName := ATypeName; FTypeLibrary := ATypeLibrary; if FTypeLibrary <> nil then FTypeLibrary.AddFreeNotification(@DoTypeLibFreed); inherited Create; end; constructor TJitType.Create(ATypeName, AUnitName: String; ATypeLibrary: TJitTypeLibrary); begin Create(ATypeName, ATypeLibrary); FUnitName := AUnitName; end; destructor TJitType.Destroy; begin inherited Destroy; if FTypeLibrary <> nil then FTypeLibrary.RemoveFreeNotification(@DoTypeLibFreed); end; { TJitDeclarationParser } procedure TJitDeclarationParser.SkipWhiteSpace; begin while DAT.FCurToken^ in [' ', #9, #10, #13] do inc(DAT.FCurToken); end; constructor TJitDeclarationParser.Create(ATokenStart: PChar); begin FStartPos := ATokenStart; DAT.FCurToken := ATokenStart; DAT.FCurTokenLen := 0; FCheckSectionEndProc := nil; SavePosition; Next; end; function TJitDeclarationParser.CurPos: Integer; begin Result := DAT.FCurToken - FStartPos; end; function TJitDeclarationParser.IsBeforeEOT: Boolean; var t: PChar; begin t := DAT.FCurToken; inc(DAT.FCurToken, DAT.FCurTokenLen); SkipWhiteSpace; Result := (DAT.FCurToken^ = #0); DAT.FCurToken := t; end; function TJitDeclarationParser.IsBeforeEotOrSectionEnd: Boolean; var t: PChar; begin t := DAT.FCurToken; inc(DAT.FCurToken, DAT.FCurTokenLen); SkipWhiteSpace; Result := (DAT.FCurToken^ = #0) or (DAT.FCurToken^ = ';') or ( (DAT.FCurToken[0] in ['e', 'E']) and (DAT.FCurToken[1] in ['n', 'N']) and (DAT.FCurToken[2] in ['d', 'D']) and (DAT.FCurToken[3] in [#0, ';', ' ', #9, #10, #13]) ); DAT.FCurToken := t; if (not Result) and Assigned(FCheckSectionEndProc) then Result := FCheckSectionEndProc(@Self); end; function TJitDeclarationParser.Next(AContext: TParseContext): TJitParserTkKind; type TCSet = set of char; var NxtTok: PChar; procedure SetResult(ATokenKind: TJitParserTkKind; ALen: Integer = 1); begin DAT.FCurTokenKind := ATokenKind; Inc(NxtTok, ALen); end; procedure SetResultForSet(ATokenKind: TJitParserTkKind; const cs: TCSet; ASkip: Integer = 0); begin DAT.FCurTokenKind := ATokenKind; NxtTok := NxtTok + ASkip; while (NxtTok^ in cs) do Inc(NxtTok); end; begin inc(DAT.FCurToken, DAT.FCurTokenLen); DAT.FCurTokenLen := 0; SkipWhiteSpace; if IsBeforeEOT then begin DAT.FCurTokenLen := 0; DAT.FCurTokenKind := ptEOT; Result := ptEOT; exit; end; DAT.FCurTokenKind := ptError; NxtTok := DAT.FCurToken; case DAT.FCurToken^ of 'a'..'z', 'A'..'Z', '_': begin SetResultForSet(ptIdent, ['a'..'z', 'A'..'Z', '_', '0'..'9']); case NxtTok - DAT.FCurToken of 2: if (AContext = pcOfExpexted) and (strlicomp('of', DAT.FCurToken, 2) = 0) then DAT.FCurTokenKind := kwOf; 3: case DAT.FCurToken^ of 's', 'S': if strlicomp('set', DAT.FCurToken, 3) = 0 then DAT.FCurTokenKind := kwSet; 'v', 'V': if strlicomp('var', DAT.FCurToken, 3) = 0 then DAT.FCurTokenKind := kwVar; 'e', 'E': if strlicomp('end', DAT.FCurToken, 3) = 0 then DAT.FCurTokenKind := kwEnd; end; 5: case DAT.FCurToken^ of 'c', 'C': if strlicomp('const', DAT.FCurToken, 3) = 0 then DAT.FCurTokenKind := kwConst else if strlicomp('class', DAT.FCurToken, 3) = 0 then DAT.FCurTokenKind := kwClass; 'a', 'A': if strlicomp('array', DAT.FCurToken, 3) = 0 then DAT.FCurTokenKind := kwArray; end; 6: case DAT.FCurToken^ of 'r', 'R': if strlicomp('record', DAT.FCurToken, 3) = 0 then DAT.FCurTokenKind := kwRecord; 's', 'S': if strlicomp('string', DAT.FCurToken, 3) = 0 then DAT.FCurTokenKind := kwString; 'p', 'P': if strlicomp('public', DAT.FCurToken, 3) = 0 then DAT.FCurTokenKind := kwPublic; 'o', 'O': if strlicomp('object', DAT.FCurToken, 3) = 0 then DAT.FCurTokenKind := kwObject; end; 7: case DAT.FCurToken^ of 'p', 'P': if strlicomp('private', DAT.FCurToken, 3) = 0 then DAT.FCurTokenKind := kwPrivate; end; 8: case DAT.FCurToken^ of 'c', 'C': if (AContext = pcFuncParamStart) and (strlicomp('constref', DAT.FCurToken, 3) = 0) then DAT.FCurTokenKind := kwConstRef; // not a keyword / needs contexct 'p', 'P': if strlicomp('property', DAT.FCurToken, 3) = 0 then DAT.FCurTokenKind := kwProperty; 'f', 'F': if strlicomp('function', DAT.FCurToken, 3) = 0 then DAT.FCurTokenKind := kwFunction; end; 9: case DAT.FCurToken[3] of 'c', 'C': if strlicomp('procedure', DAT.FCurToken, 3) = 0 then DAT.FCurTokenKind := kwProcedure; 't', 'T': if strlicomp('protected', DAT.FCurToken, 3) = 0 then DAT.FCurTokenKind := kwProcedure; 'l', 'L': if strlicomp('published', DAT.FCurToken, 3) = 0 then DAT.FCurTokenKind := kwPublished; end; end; end; '0'..'9': SetResultForSet(ptNum, ['0'..'9']); '$': SetResultForSet(ptNum, ['0'..'9', 'a'..'f', 'A'..'F'], 1); '&': if DAT.FCurToken[1] in ['0'..'7'] then SetResultForSet(ptNum, ['0'..'7'], 1) else begin SetResultForSet(ptIdent, ['a'..'z', 'A'..'Z', '_', '0'..'9'], 1); // escaped ident end; '%': SetResultForSet(ptNum, ['0'..'1'], 1); '-','+': case DAT.FCurToken[1] of '0'..'9': SetResultForSet(ptNum, ['0'..'9'], 1); '$': SetResultForSet(ptNum, ['0'..'9', 'a'..'f', 'A'..'F'], 2); '&': SetResultForSet(ptNum, ['0'..'7'], 2); '%': SetResultForSet(ptNum, ['0'..'1'], 2); //else // error / return empty end; '.': if DAT.FCurToken[1] = '.' then SetResult(ptDotDot, 2) else SetResult(ptDot); '#': case DAT.FCurToken[1] of '0'..'9': SetResultForSet(ptChar, ['0'..'9'], 1); '$': SetResultForSet(ptChar, ['0'..'9', 'a'..'f', 'A'..'F'], 2); '&': SetResultForSet(ptChar, ['0'..'7'], 2); '%': SetResultForSet(ptChar, ['0'..'1'], 2); //else // error / return empty end; '''': if (DAT.FCurToken[1] = '''') then SetResult(ptEmptyString, 2) else if (DAT.FCurToken[1] <> #0) and (DAT.FCurToken[2] = '''') then SetResult(ptChar, 3); '(': SetResult(ptRoundOpen); ')': SetResult(ptRoundClose); '[': SetResult(ptSquareOpen); ']': SetResult(ptSquareClose); ',': SetResult(ptComma); ':': SetResult(ptColon); ';': SetResult(ptSemicolon); '=': SetResult(ptEqual); //else // error / return empty // only chars => subset of char else begin // error DAT.FCurTokenKind := ptSymbol; inc(NxtTok); end; end; DAT.FCurTokenLen := NxtTok - DAT.FCurToken; Result := DAT.FCurTokenKind; end; function TJitDeclarationParser.CurrentToken: String; var t: PChar; l: Integer; begin case DAT.FCurTokenKind of ptNone, ptError, ptEOT: Result := ''; ptEmptyString: Result := ''''; ptChar: case DAT.FCurToken^ of '#': begin SetLength(Result, DAT.FCurTokenLen - 1); if DAT.FCurTokenLen > 1 then move((DAT.FCurToken+1)^, Result[1], DAT.FCurTokenLen - 1); Result := char(StrToInt(Result)); end; '''': Result := (DAT.FCurToken + 1)^; else raise JitTypeParserExceptionSyntaxError.Create(CurPos, '', 'Internal parser error'); end; else begin t := DAT.FCurToken; l := DAT.FCurTokenLen; if (DAT.FCurTokenKind = ptIdent) and (t^ = '&') then begin inc(t); dec(l); end; SetLength(Result, DAT.FCurTokenLen); if DAT.FCurTokenLen > 0 then move(DAT.FCurToken^, Result[1], DAT.FCurTokenLen); end; end; end; function TJitDeclarationParser.CurrentTokenAsNum(out IsQWord: Boolean): Int64; var s: String; begin if DAT.FCurTokenKind <> ptNum then raise JitTypeParserExceptionSyntaxError.Create(CurPos, CurrentToken, 'Number expected'); IsQWord := False; s := CurrentToken; if not TryStrToInt64(s, Result) then if TryStrToQWord(s, QWord(Result)) then IsQWord := True else raise JitTypeParserExceptionSyntaxError.Create(CurPos, CurrentToken, 'Number expected'); end; function TJitDeclarationParser.CurrentTokenRaw: String; begin case DAT.FCurTokenKind of ptNone, ptError, ptEOT: Result := ''; ptEmptyString: Result := ''''; else begin SetLength(Result, DAT.FCurTokenLen); if DAT.FCurTokenLen > 0 then move(DAT.FCurToken^, Result[1], DAT.FCurTokenLen); end; end; end; function TJitDeclarationParser.NextToken: String; begin Next; Result := CurrentTokenRaw; end; function TJitDeclarationParser.PeekTokenRaw: String; var t: TJitDeclarationParserData; begin t := DAT; Result := NextToken; DAT := t; end; function TJitDeclarationParser.PeekKind(AContext: TParseContext ): TJitParserTkKind; var t: TJitDeclarationParserData; begin t := DAT; Result := Next(AContext); DAT := t; end; procedure TJitDeclarationParser.GetQualifiedIdent(out APath, AnIdent: String); var ct: PChar; begin APath := ''; AnIdent := ''; if CurrentKind <> ptIdent then raise JitTypeParserExceptionSyntaxError.Create(CurPos, CurrentToken, 'Identifier expected'); ct := DAT.FCurToken; AnIdent := CurrentToken; while ((DAT.FCurToken + DAT.FCurTokenLen)^ = '.') and ( ((DAT.FCurToken + DAT.FCurTokenLen + 1)^ in ['a'..'z', 'A'..'Z', '_']) or ((DAT.FCurToken + DAT.FCurTokenLen + 1)^ = '&') and ((DAT.FCurToken + DAT.FCurTokenLen + 2)^ in ['a'..'z', 'A'..'Z', '_']) ) do begin if APath <> '' then APath := APath + '.'; APath := APath + AnIdent; Next; Next; AnIdent := CurrentToken; end; DAT.FCurTokenLen := DAT.FCurToken - ct + DAT.FCurTokenLen; DAT.FCurToken := ct; end; procedure TJitDeclarationParser.GetQualifiedIdent(out APath, AnIdent1, AnIdent2: String); var ct: PChar; begin APath := ''; AnIdent1 := ''; AnIdent2 := ''; if CurrentKind <> ptIdent then raise JitTypeParserExceptionSyntaxError.Create(CurPos, CurrentToken, 'Identifier expected'); ct := DAT.FCurToken; AnIdent2 := CurrentToken; while ((DAT.FCurToken + DAT.FCurTokenLen)^ = '.') and ( ((DAT.FCurToken + DAT.FCurTokenLen + 1)^ in ['a'..'z', 'A'..'Z', '_']) or ((DAT.FCurToken + DAT.FCurTokenLen + 1)^ = '&') and ((DAT.FCurToken + DAT.FCurTokenLen + 2)^ in ['a'..'z', 'A'..'Z', '_']) ) do begin if (APath <> '') and (AnIdent1 <> '') then APath := APath + '.'; APath := APath + AnIdent1; AnIdent1 := AnIdent2; Next; Next; AnIdent2 := CurrentToken; end; DAT.FCurTokenLen := DAT.FCurToken - ct + DAT.FCurTokenLen; DAT.FCurToken := ct; end; procedure TJitDeclarationParser.SavePosition; begin FSavePoint := DAT; end; procedure TJitDeclarationParser.RestorePosition; begin DAT := FSavePoint; end; { TJitTypeInfo.TRefCountedTypeInfo } function TJitTypeInfo.TRefCountedTypeInfo.IndexOf(ATypeInfo: PTypeInfo): integer; begin if NestedReferrences = nil then exit; Result := NestedReferrences.Count - 1; while Result >= 0 do begin if (NestedReferrences[Result] is TRefCountedTypeInfo) and (TRefCountedTypeInfo(NestedReferrences[Result]).TypeInfo = ATypeInfo) then exit; dec(Result); end; end; procedure TJitTypeInfo.TRefCountedTypeInfo.AddToList(ATypeInfo: TJitType); begin if ATypeInfo <> nil then AddToList(ATypeInfo.LockReference); end; procedure TJitTypeInfo.TRefCountedTypeInfo.RemoveFromList(ATypeInfo: PTypeInfo); var i: Integer; begin if NestedReferrences = nil then exit; i := IndexOf(ATypeInfo); if i < 0 then exit; NestedReferrences[i].ReleaseLock; NestedReferrences.Delete(i); end; procedure TJitTypeInfo.TRefCountedTypeInfo.SetTypeInfo(ATypeInfo: PTypeInfo); begin if (RefCount > 1) and (FTypeInfo <> nil) then raise Exception.Create('set TypeInfo while referrenced'); if (FTypeInfo <> nil) then begin ClearList; Freemem(FTypeInfo); end; FTypeInfo := ATypeInfo; end; procedure TJitTypeInfo.TRefCountedTypeInfo.DoRefCountZero; begin inherited DoRefCountZero; if FTypeInfo <> nil then begin Freemem(FTypeInfo); FTypeInfo := nil; end; end; constructor TJitTypeInfo.TRefCountedTypeInfo.Create(ATypeInfo: PTypeInfo); begin inherited Create; FTypeInfo := ATypeInfo; end; { TJitTypeInfo } function TJitTypeInfo.GetTypeInfo: PTypeInfo; begin if FTypeInfo = nil then ParseFromDeclaration; Result := FTypeInfo; end; function TJitTypeInfo.GetLockReferenceObj: TRefCountedJitReference; begin Result := RefCountedTypeInfo; end; function TJitTypeInfo.IsConstTypeInfo: Boolean; begin Result := FIsConstTypeInfo; end; procedure TJitTypeInfo.SetFTypeInfo(AValue: PTypeInfo); begin if FTypeInfo = AValue then Exit; if (FTypeInfo <> nil) and (FRefCountedTypeInfo = nil) then Freemem(FTypeInfo); FTypeInfo := AValue; FIsConstTypeInfo := False; if FRefCountedTypeInfo <> nil then begin if (FRefCountedTypeInfo.RefCount = 1) or (FRefCountedTypeInfo.FTypeInfo = nil) then FRefCountedTypeInfo.SetTypeInfo(AValue) else begin FRefCountedTypeInfo.ReleaseLock; FRefCountedTypeInfo := TRefCountedTypeInfo.Create(AValue); end; end; end; procedure TJitTypeInfo.SetConstFTypeInfo(AValue: PTypeInfo); begin assert((AValue = nil) or (FTypeInfo <> AValue) or (FRefCountedTypeInfo = nil), 'TJitTypeInfo.SetConstFTypeInfo: (AValue = nil) or (FTypeInfo <> AValue) or (FRefCountedTypeInfo = nil)'); if FTypeInfo = AValue then Exit; if (FTypeInfo <> nil) and (FRefCountedTypeInfo = nil) then Freemem(FTypeInfo); FTypeInfo := AValue; FIsConstTypeInfo := True; if FRefCountedTypeInfo <> nil then begin FRefCountedTypeInfo.ReleaseLock; FRefCountedTypeInfo := Nil; end; end; function TJitTypeInfo.RefCountedTypeInfo: TRefCountedTypeInfo; begin if FRefCountedTypeInfo = nil then begin (* FTypeInfo may be nil, but a refernce can be got anyway *) if FIsConstTypeInfo then FRefCountedTypeInfo := TRefCountedTypeInfo.Create(nil) else FRefCountedTypeInfo := TRefCountedTypeInfo.Create(FTypeInfo); end; Result := FRefCountedTypeInfo; end; procedure TJitTypeInfo.ParseFromDeclaration(AParser: PJitDeclarationParser); var Decl: String; TheTokenParser: TJitDeclarationParser; TokenParser: PJitDeclarationParser; function IsBeforeEOT(AnIncludeSoftEOT: Boolean = False): Boolean; begin if AnIncludeSoftEOT then Result := TokenParser^.IsBeforeEotOrSectionEnd else Result := TokenParser^.IsBeforeEOT; end; procedure AssertIsIdent(tk: TJitParserTkKind; s: string = ''); begin if tk <> ptIdent then begin if s = '' then s := TokenParser^.CurrentToken; raise JitTypeParserExceptionSyntaxError.Create(TokenParser^.CurPos, s, 'Identifier expected'); end; end; procedure AssertExpectedToken(tk: TJitParserTkKind; AExp: TJitParserTkKinds; s: string = ''); var e, b: String; a: TJitParserTkKind; begin if not (tk in AExp) then begin if s = '' then s := TokenParser^.CurrentToken; e := ''; for a in TJitParserTkKind do if a in AExp then begin WriteStr(b, a); e := e + ', ' + copy(b, 3, Length(b)); end; delete(e, 1, 2); raise JitTypeParserExceptionSyntaxError.Create(TokenParser^.CurPos, s, 'Unexpected token, expected ' + e); end; end; procedure AssertIsBeforeEOT(AnIncludeSoftEOT: Boolean = False); begin if not IsBeforeEOT(AnIncludeSoftEOT) then raise JitTypeParserExceptionSyntaxError.Create(TokenParser^.CurPos, TokenParser^.CurrentToken, 'End of declaration expected'); end; procedure AssertFoundTypeInfo(const t: PTypeInfo; const s: string); begin if t = nil then raise JitTypeParserExceptionTypeNotFound.Create(TokenParser^.CurPos, s, 'No typeinfo for: '); end; var LastIntTypeInfoFound: TJitType; function FindTypeInfo(n: String; AddToRefList: Boolean; AnUnitName: String = ''; ASearchOptions: TTypeSearchOptions = []): PTypeInfo; var jt: TJitType; begin LastIntTypeInfoFound := nil; if (AnUnitName = '') and (ASearchOptions = []) then AnUnitName := FUnitName; if TypeLibrary <> nil then begin jt := TypeLibrary.FindType(n, AnUnitName, ASearchOptions); if (jt = nil) and (n <> '') and (n[1] = '&') then begin delete(n, 1, 1); jt := TypeLibrary.FindType(n, AnUnitName, ASearchOptions); end; if jt <> nil then begin Result := jt.TypeInfo; AssertFoundTypeInfo(Result, n); LastIntTypeInfoFound := jt; if AddToRefList then RefCountedTypeInfo.AddToList(jt); exit; end; end; if (n <> '') and (n[1] = '&') then delete(n, 1, 1); Result := TypeInfoByName(n); end; function GetIdentList(out AList: TStringArray; const ASeparator: TJitParserTkKinds): TJitParserTkKind; var l: Integer; begin l := 0; AList := nil; SetLength(AList, 10); repeat if l >= Length(AList) then SetLength(AList, l + 10); AssertIsIdent(TokenParser^.Next); AList[l] := TokenParser^.CurrentToken; inc(l); Result := TokenParser^.Next; until not(Result in ASeparator); SetLength(AList, l); end; procedure DoEnum; var Elems: TStringArray; s, un: String; MemSize: Integer; RttiWriter: TJitRttiWriterTkEnum; tk: TJitParserTkKind; begin tk := GetIdentList(Elems, [ptComma]); AssertExpectedToken(tk, [ptRoundClose]); AssertIsBeforeEOT(AParser <> nil); MemSize := TJitRttiWriterTypeInfo.NewSizeFor(FTypeName, tkEnumeration); for s in Elems do TJitRttiWriterTkEnum.AddSizeForElemName(MemSize, s); un := FUnitName; if un = '' then un := '$u'; // must write some unitname TJitRttiWriterTkEnum.AddSizeForElemName(MemSize, un); TJitRttiWriterTkEnum.FinishSize(MemSize); SetFTypeInfo(AllocMem(MemSize)); RttiWriter := TJitRttiWriterTkEnum.Create(FTypeInfo, FTypeName, Length(Elems)); for s in Elems do RttiWriter.WriteEnumElemName(s); RttiWriter.WriteUnitName(un); assert(RttiWriter.CurDestMemPos<=Pointer(FTypeInfo)+MemSize, 'DoEnum: RttiWriter.CurDestMemPos<=Pointer(FTypeInfo)+MemSize'); RttiWriter.Free; end; procedure DoProcedure(AnIsFunction: Boolean); const FORMAL_PARAM_NAME = '$formal'; function TNameToTInfo(tn, tu: string; var rmem: Pointer): TypeInfoPtr; inline; var t: PTypeInfo; begin if (tn = '') or (tn = FORMAL_PARAM_NAME) then exit(nil); if tu <> '' then t := FindTypeInfo(tn, True, tu, [tsoOnlyUnit]) else t := FindTypeInfo(tn, True, FUnitName); AssertFoundTypeInfo(t, tn); Result := PTypeInfoToTypeInfoPtr(t, rmem); end; type TFuncParam = record Flags: TParamFlags; NameList: TStringArray; TypeName, TypeUnit: String; end; var ParamList: array of TFuncParam; CurParams: ^TFuncParam; ResTypeName, ResTypeUnit, s, s2: String; ti_int64: PTypeInfo; HasName, OfObject, HasOpenArray: Boolean; Flags: TParamFlags; ParamListCnt, ParamCnt, MemSize, PtrRedirectMemSize: Integer; param: TFuncParam; PtrRedirectMem: Pointer; RttiWriterMeth: TJitRttiWriterTkMethod; RttiWriterProc: TJitRttiWriterTkProcVar; tk: TJitParserTkKind; begin HasName := False; OfObject := pfAlwaysAsMethod in FParseFlags; ParamListCnt := 0; ParamCnt := 0; HasOpenArray := False; tk := TokenParser^.PeekKind; if (pfAllowProcName in FParseFlags) and (tk = ptIdent) then begin TokenParser^.Next; TokenParser^.GetQualifiedIdent(s, s2); HasName := True; OfObject := s <> ''; tk := TokenParser^.PeekKind; end; if tk = ptRoundOpen then begin // read arguments TokenParser^.Next; tk := TokenParser^.PeekKind; if (tk <> ptRoundClose) then begin repeat Flags := []; tk := TokenParser^.PeekKind(pcFuncParamStart); case tk of kwVar: Flags := Flags + [pfVar]; kwOut: Flags := Flags + [pfOut]; kwConst: Flags := Flags + [pfConst]; kwConstRef: Flags := Flags + [pfConstRef]; end; if Flags <> [] then TokenParser^.Next; SetLength(ParamList, ParamListCnt + 1); CurParams := @ParamList[ParamListCnt]; CurParams^.Flags := Flags; tk := GetIdentList(CurParams^.NameList, [ptComma]); inc(ParamCnt, Length(CurParams^.NameList)); if tk = ptColon then begin tk := TokenParser^.Next; if tk = kwArray then begin AssertExpectedToken(TokenParser^.Next(pcOfExpexted), [kwOf]); HasOpenArray := True; CurParams^.Flags := CurParams^.Flags + [pfArray, pfReference]; inc(ParamCnt, Length(CurParams^.NameList)); TokenParser^.Next; // TODO: if s = 'const' // array of const => array of TVarRec end; TokenParser^.GetQualifiedIdent(CurParams^.TypeUnit, CurParams^.TypeName); tk := TokenParser^.Next; if tk = ptEqual then // default value while not (tk in [ptSemicolon, ptRoundClose, ptEOT]) do tk := TokenParser^.Next; end else begin CurParams^.TypeName := FORMAL_PARAM_NAME; CurParams^.TypeUnit := ''; end; // else untyped param inc(ParamListCnt); until tk <> ptSemicolon; AssertExpectedToken(TokenParser^.CurrentKind, [ptRoundClose]); end else TokenParser^.Next; // get the ')' from TokenParser^.PeekKind; end; if AnIsFunction then begin AssertExpectedToken(TokenParser^.Next, [ptColon]); TokenParser^.Next; TokenParser^.GetQualifiedIdent(ResTypeUnit, ResTypeName); end else begin ResTypeName := ''; ResTypeUnit := ''; end; tk := TokenParser^.PeekKind(pcOfExpexted); if (not HasName) and (tk = kwOf) then begin TokenParser^.Next; AssertExpectedToken(TokenParser^.Next, [kwObject]); OfObject := True; tk := TokenParser^.PeekKind; end; if tk = ptSemicolon then begin // TODO: check cdecl.... end; AssertIsBeforeEOT(AParser <> nil); if HasOpenArray then begin ti_int64 := system.TypeInfo(Int64); AssertFoundTypeInfo(ti_int64, 'int64'); end; if OfObject then begin // write tkMethod inc(ParamCnt); // $self MemSize := TJitRttiWriterTypeInfo.NewSizeFor(FTypeName, tkMethod); PtrRedirectMemSize := 0; TJitRttiWriterTkMethod.AddSizeForMethodField(MemSize, PtrRedirectMemSize, '$self', 'Pointer'); for param in ParamList do for s in param.NameList do begin TJitRttiWriterTkMethod.AddSizeForMethodField(MemSize, PtrRedirectMemSize, s, param.TypeName); if pfArray in param.Flags then TJitRttiWriterTkMethod.AddSizeForMethodField(MemSize, PtrRedirectMemSize, '$high'+s, 'Int64'); // TODO: '$formal' param do not need PtrRedirectMemSize end; if AnIsFunction then TJitRttiWriterTkMethod.AddSizeForMethodResult(MemSize, PtrRedirectMemSize, ResTypeName); TJitRttiWriterTkMethod.AddSizeForCallingConv(MemSize); TJitRttiWriterTkMethod.FinalizeSizeForMethodTypeInfo(MemSize); if PtrRedirectMemSize <> 0 then MemSize := aligntoptr(MemSize); // for the start of PtrRedirectMemSize SetFTypeInfo(AllocMem(MemSize + PtrRedirectMemSize)); PtrRedirectMem := aligntoptr(Pointer(FTypeInfo) + MemSize); if AnIsFunction then RttiWriterMeth := TJitRttiWriterTkMethod.Create(FTypeInfo, FTypeName, mkFunction, ParamCnt) else RttiWriterMeth := TJitRttiWriterTkMethod.Create(FTypeInfo, FTypeName, mkProcedure, ParamCnt); try try RttiWriterMeth.WriteParamInfo('$self', 'Pointer', [pfHidden, pfSelf]); // Params: Flags, ParamName, TypeName for param in ParamList do for s in param.NameList do begin RttiWriterMeth.WriteParamInfo(s, param.TypeName, param.Flags); if pfArray in param.Flags then RttiWriterMeth.WriteParamInfo('$high'+s, 'Int64', [pfHidden, pfHigh, pfConst]); end; if AnIsFunction then begin RttiWriterMeth.WriteResultInfo(ResTypeName, TNameToTInfo(ResTypeName, ResTypeUnit, PtrRedirectMem)); end; RttiWriterMeth.WriteParamCallConv(ccReg); // Params: TypeInfo RttiWriterMeth.WriteParamType(PTypeInfoToTypeInfoPtr(system.TypeInfo(Pointer), PtrRedirectMem)); for param in ParamList do begin for s in param.NameList do begin RttiWriterMeth.WriteParamType(TNameToTInfo(param.TypeName, param.TypeUnit, PtrRedirectMem)); if pfArray in param.Flags then // TODO: int64 redirection can be created once and for all RttiWriterMeth.WriteParamType(PTypeInfoToTypeInfoPtr(ti_int64, PtrRedirectMem)); end; end; assert(RttiWriterMeth.CurDestMemPos<=Pointer(FTypeInfo)+MemSize, 'DoProcedure: RttiWriterMeth.CurDestMemPos<=Pointer(FTypeInfo)+MemSize'); except //TODO: at this point, any type that got our typeinfo during recursion, has an invalid typeinfo SetFTypeInfo(nil); raise; end finally RttiWriterMeth.Free; end; end else begin // write tkProcVar MemSize := TJitRttiWriterTypeInfo.NewSizeFor(FTypeName, tkProcVar); if AnIsFunction then PtrRedirectMemSize := SIZE_OF_TYPEINFO_PPOINTER else PtrRedirectMemSize := 0; for param in ParamList do for s in param.NameList do begin TJitRttiWriterTkProcVar.AddSizeForProcVarField(MemSize, PtrRedirectMemSize, s); if pfArray in param.Flags then TJitRttiWriterTkProcVar.AddSizeForProcVarField(MemSize, PtrRedirectMemSize, '$high'+s); end; if PtrRedirectMemSize <> 0 then MemSize := aligntoptr(MemSize); SetFTypeInfo(AllocMem(MemSize + PtrRedirectMemSize)); PtrRedirectMem := Pointer(FTypeInfo) + MemSize; RttiWriterProc := TJitRttiWriterTkProcVar.Create(FTypeInfo, FTypeName, 0, ccReg, TNameToTInfo(ResTypeName, ResTypeUnit, PtrRedirectMem), ParamCnt); try try for param in ParamList do begin for s in param.NameList do begin // TODO: keep a referenc => internal type-lib FInternalTypeLib RttiWriterProc.WriteProcedureParam(s, TNameToTInfo(param.TypeName, param.TypeUnit, PtrRedirectMem), param.Flags); if pfArray in param.Flags then RttiWriterProc.WriteProcedureParam('$high'+s, PTypeInfoToTypeInfoPtr(ti_int64, PtrRedirectMem), [pfHidden, pfHigh, pfConst]); end; end; assert(RttiWriterProc.CurDestMemPos<=Pointer(FTypeInfo)+MemSize, 'DoProcedure: RttiWriterProc.CurDestMemPos<=Pointer(FTypeInfo)+MemSize'); except //TODO: at this point, any type that got our typeinfo during recursion, has an invalid typeinfo SetFTypeInfo(nil); raise; end finally RttiWriterProc.Free; end; end; assert(PtrRedirectMem <= Pointer(FTypeInfo) + MemSize + PtrRedirectMemSize, 'DoProcedure: PtrRedirectMem <= Pointer(FTypeInfo) + MemSize + PtrRedirectMemSize'); end; procedure DoRecord; type TRecEntry = record NameList: TStringArray; TypeInfo: PTypeInfo; end; var s, TpName, TpUnit: String; tk: TJitParserTkKind; RecEntryList: array of TRecEntry; CurRecEntry: ^TRecEntry; SubJitTypeInfo: TJitTypeInfo; RecEntryListCnt, RecEntryCnt, ManagedCount: Integer; RecMemSize, InitTblMemSize, PtrRedirectMemSize, RecInstanceSize: Integer; RecEntry: TRecEntry; PtrRedirectMem: Pointer; RttiWriter: TJitRttiWriterTkRecord; IsEmbeddedTp: Boolean; begin // Todo: peak "case" RecEntryCnt := 0; ManagedCount := 0; RecEntryListCnt := 0; tk := TokenParser^.PeekKind; if tk <> kwEnd then begin repeat SetLength(RecEntryList, RecEntryListCnt + 1); CurRecEntry := @RecEntryList[RecEntryListCnt]; tk := GetIdentList(CurRecEntry^.NameList, [ptComma]); inc(RecEntryCnt, Length(CurRecEntry^.NameList)); AssertExpectedToken(tk, [ptColon]); IsEmbeddedTp := True; tk := TokenParser^.Next; TokenParser^.SavePosition; if tk = ptIdent then begin TokenParser^.GetQualifiedIdent(TpUnit, TpName); tk := TokenParser^.Next; if tk in [ptSemicolon, kwEnd] then begin IsEmbeddedTp := False; if TpUnit <> '' then CurRecEntry^.TypeInfo := FindTypeInfo(TpName, True, TpUnit, [tsoOnlyUnit]) else CurRecEntry^.TypeInfo := FindTypeInfo(TpName, True, FUnitName); end; end; if IsEmbeddedTp then begin // scan embedded type TokenParser^.RestorePosition; SubJitTypeInfo := TJitTypeInfo.Create('', FDeclaration, FUnitName, TypeLibrary); SubJitTypeInfo.ParseFromDeclaration(TokenParser); CurRecEntry^.TypeInfo := SubJitTypeInfo.FTypeInfo; // do not use property / do not scan again if nil RefCountedTypeInfo.AddToList(SubJitTypeInfo); SubJitTypeInfo.Free; tk := TokenParser^.Next; end; AssertFoundTypeInfo(CurRecEntry^.TypeInfo, ''); if CurRecEntry^.TypeInfo.isManaged then inc(ManagedCount, Length(CurRecEntry^.NameList)); if (tk = ptSemicolon) and (TokenParser^.PeekKind = kwEnd) then tk := TokenParser^.Next; until tk <> ptSemicolon; AssertExpectedToken(TokenParser^.CurrentKind, [kwEnd]); end else TokenParser^.Next; // read the "end" AssertIsBeforeEOT(AParser <> nil); RecMemSize := TJitRttiWriterTypeInfo.NewSizeFor(FTypeName, tkRecord) + SizeOf(TManagedField) * RecEntryCnt; InitTblMemSize := TJitRttiWriterRecInitInfo.NewSizeForInitTable(FTypeName, ManagedCount); PtrRedirectMemSize := SIZE_OF_TYPEINFO_PPOINTER * RecEntryCnt; RecInstanceSize := 0; SetFTypeInfo(AllocMem(RecMemSize + InitTblMemSize + PtrRedirectMemSize)); PtrRedirectMem := pointer(FTypeInfo) + RecMemSize + InitTblMemSize; RttiWriter := TJitRttiWriterTkRecord.Create(FTypeInfo, Pointer(FTypeInfo) + RecMemSize, FTypeName, RecEntryCnt, ManagedCount); for RecEntry in RecEntryList do for s in RecEntry.NameList do begin RttiWriter.WriteField(PTypeInfoToTypeInfoPtr(RecEntry.TypeInfo, PtrRedirectMem), RecInstanceSize, RecEntry.TypeInfo.IsManaged); RecInstanceSize := RecInstanceSize + RecEntry.TypeInfo.DataSize; end; RttiWriter.WriteRecSize(RecInstanceSize); RttiWriter.RecInitFieldWriter.WriteSize(RecInstanceSize); assert(PtrRedirectMem <= Pointer(FTypeInfo)+RecMemSize+InitTblMemSize+PtrRedirectMemSize, 'DoRecord: PtrRedirectMem <= Pointer(FTypeInfo)+RecMemSize+InitTblMemSize+PtrRedirectMemSize'); assert(RttiWriter.CurDestMemPos <= Pointer(FTypeInfo)+RecMemSize, 'DoRecord: RttiWriter.CurDestMemPos <= Pointer(FTypeInfo)+RecMemSize'); assert(RttiWriter.RecInitFieldWriter.CurDestMemPos <= Pointer(FTypeInfo)+RecMemSize+InitTblMemSize, 'DoRecord: RttiWriter.RecInitFieldWriter.CurDestMemPos <= Pointer(FTypeInfo)+RecMemSize+InitTblMemSize'); RttiWriter.Free; end; procedure DoShortString; var i: Int64; l: Integer; qw: Boolean; begin AssertExpectedToken(TokenParser^.Next, [ptSquareOpen]); TokenParser^.Next; i := TokenParser^.CurrentTokenAsNum(qw); if (i < 1) or (i > 255) then raise JitTypeParserException.Create(TokenParser^.CurPos, TokenParser^.CurrentToken, 'shortstring length out of range'); AssertExpectedToken(TokenParser^.Next, [ptSquareClose]); AssertIsBeforeEOT(AParser <> nil); l := TJitRttiWriterTypeInfo.NewSizeFor(FTypeName, tkSString); SetFTypeInfo(GetMem(l)); FTypeInfo^.Kind := tkSString; FTypeInfo^.Name := FTypeName; GetTypeData(FTypeInfo)^.MaxLength := i; end; procedure DoSet; var s, s2: String; enum: PTypeInfo; SubJitTypeInfo: TJitTypeInfo; ByteSize, MemSize: LongInt; PtrRedirectMem: Pointer; RttiWriter: TJitRttiWriterTkSet; IsEmbeddedTp: Boolean; tk: TJitParserTkKind; begin AssertExpectedToken(TokenParser^.Next(pcOfExpexted), [kwOf]); IsEmbeddedTp := True; tk := TokenParser^.Next; TokenParser^.SavePosition; // So we can roll back to current = 'of', because recursive call starts with NEXT if tk = ptIdent then begin TokenParser^.GetQualifiedIdent(s2, s); if IsBeforeEOT(AParser <> nil) then begin IsEmbeddedTp := False; if s2 <> '' then enum := FindTypeInfo(s, True, s2, [tsoOnlyUnit]) else enum := FindTypeInfo(s, True, FUnitName); end; end; if IsEmbeddedTp then begin s := ''; TokenParser^.RestorePosition; SubJitTypeInfo := TJitTypeInfo.Create('', FDeclaration, FUnitName, TypeLibrary); SubJitTypeInfo.ParseFromDeclaration(TokenParser); enum := SubJitTypeInfo.FTypeInfo; // do not use property / do not scan again if nil RefCountedTypeInfo.AddToList(SubJitTypeInfo); SubJitTypeInfo.Free; AssertIsBeforeEOT(AParser <> nil); end; AssertFoundTypeInfo(enum, s); case enum^.Kind of tkEnumeration, tkInteger,tkChar,tkBool,tkWChar: ByteSize := GetTypeData(enum)^.MaxValue - GetTypeData(enum)^.MinValue + 1; tkInt64: ByteSize := GetTypeData(enum)^.MaxInt64Value - GetTypeData(enum)^.MinInt64Value + 1; tkQWord: ByteSize := GetTypeData(enum)^.MaxQWordValue - GetTypeData(enum)^.MinQWordValue + 1; else raise JitTypeParserExceptionSyntaxError.Create(TokenParser^.CurPos, TokenParser^.CurrentToken, 'Expected enumeration or sub-range'); end; MemSize := aligntoptr(TJitRttiWriterTypeInfo.NewSizeFor(FTypeName, tkSet)); SetFTypeInfo(AllocMem(MemSize + SIZE_OF_TYPEINFO_PPOINTER)); PtrRedirectMem := Pointer(FTypeInfo) + MemSize; RttiWriter := TJitRttiWriterTkSet.Create(FTypeInfo, FTypeName, ByteSize, PTypeInfoToTypeInfoPtr(enum, PtrRedirectMem)); RttiWriter.Free; end; procedure DoSubRange(tk: TJitParserTkKind; s: String); // s has been read with TokenParser^.Next procedure ParseValue(CurKind: TJitParserTkKind; out AnOrdVal: Int64; out AJitType: TJitType; out APTypeInfo: PTypeInfo; ALowJitType: TJitType = nil); var EnumUnit, EnumType, EnumMember: String; JitDummy: TJitType; InfoDummy: PTypeInfo; MemberVal: Integer; IsQw: Boolean; begin LastIntTypeInfoFound := nil; APTypeInfo := nil; case CurKind of ptIdent: if (TypeLibrary <> nil) then begin TokenParser^.GetQualifiedIdent(EnumUnit, EnumType, EnumMember); case TokenParser^.PeekKind of ptRoundOpen: begin // we have "EnumType(val).. if EnumUnit <> '' then EnumUnit := EnumUnit + '.'; EnumUnit := EnumUnit + EnumType; if EnumUnit = '' then APTypeInfo := FindTypeInfo(EnumMember, False, FUnitName) // EnumMember countains the typename else APTypeInfo := FindTypeInfo(EnumMember, False, EnumUnit, [tsoOnlyUnit]); TokenParser^.Next; CurKind := TokenParser^.Next; // skip the "(" AJitType := LastIntTypeInfoFound; ParseValue(CurKind, AnOrdVal, JitDummy, InfoDummy); LastIntTypeInfoFound := AJitType; AssertExpectedToken(TokenParser^.Next, [ptRoundClose]); end; else begin if EnumType <> '' then begin // We have "unit.EnumType.Member" or "EnumType.Member" if EnumUnit = '' then APTypeInfo := FindTypeInfo(EnumType, False, FUnitName) else APTypeInfo := FindTypeInfo(EnumType, False, EnumUnit, [tsoOnlyUnit]); AssertFoundTypeInfo(APTypeInfo, TokenParser^.CurrentTokenRaw); if APTypeInfo^.Kind <> tkEnumeration then raise JitTypeParserExceptionSyntaxError.Create(TokenParser^.CurPos, TokenParser^.CurrentToken, 'Enumeration type expected: '); AnOrdVal := GetEnumValue(APTypeInfo, EnumMember); if AnOrdVal < 0 then raise JitTypeParserExceptionSyntaxError.Create(TokenParser^.CurPos, EnumMember,'Identifier not found'); end else begin // We have just "Member" if (ALowJitType = nil) or (ALowJitType.TypeInfo^.Kind <> tkEnumeration) then begin LastIntTypeInfoFound := TypeLibrary.FindTypeForEnumElem(EnumMember, MemberVal, FUnitName); AnOrdVal := MemberVal; if LastIntTypeInfoFound <> nil then APTypeInfo := LastIntTypeInfoFound.TypeInfo; end else begin // parsing high end of range / must be same type APTypeInfo := ALowJitType.TypeInfo; LastIntTypeInfoFound := ALowJitType; AnOrdVal := GetEnumValue(APTypeInfo, EnumMember); if AnOrdVal < 0 then raise JitTypeParserExceptionSyntaxError.Create(TokenParser^.CurPos, EnumMember,'Identifier not found'); end; end; end; end; AssertFoundTypeInfo(APTypeInfo, TokenParser^.CurrentTokenRaw); end; ptNum: begin AnOrdVal := TokenParser^.CurrentTokenAsNum(IsQw); if IsQw then APTypeInfo := system.TypeInfo(QWord) else if (AnOrdVal > high(LongInt)) or (AnOrdVal < low(LongInt)) then APTypeInfo := system.TypeInfo(Int64) else APTypeInfo := system.TypeInfo(longint); end; ptChar: begin AnOrdVal := ord(s[1]); APTypeInfo := system.TypeInfo(Char); end; else raise JitTypeParserExceptionSyntaxError.Create(TokenParser^.CurPos, TokenParser^.CurrentToken, 'Expected enumeration or sub-range'); end; AJitType := LastIntTypeInfoFound; end; var LowVal, HighVal, i: Int64; LowType, HighType: PTypeInfo; MemSize, PtrRedirectMemSize: Integer; RttiWriterEnum: TJitRttiWriterTkEnum; PtrRedirectMem: Pointer; Signed: Boolean; RttiWriterIntRange: TJitRttiWriterOrdinal; LowJitType, HighJitType: TJitType; un: String; begin ParseValue(tk, LowVal, LowJitType, LowType); AssertExpectedToken(TokenParser^.Next, [ptDotDot]); ParseValue(TokenParser^.Next, HighVal, HighJitType, HighType, LowJitType); if HighVal < LowVal then raise JitTypeParserException.Create(TokenParser^.CurPos, '', 'Negative range for set'); AssertIsBeforeEOT(AParser <> nil); case LowType^.Kind of tkEnumeration: begin if HighType <> LowType then raise JitTypeParserException.Create(TokenParser^.CurPos, '', 'Type mismatch between low and high bound'); MemSize := TJitRttiWriterTypeInfo.NewSizeFor(FTypeName, tkEnumeration); PtrRedirectMemSize := SIZE_OF_TYPEINFO_PPOINTER; MemSize := aligntoptr(MemSize); // for the start of PtrRedirectMemSize i := LowVal; while i <= HighVal do begin TJitRttiWriterTkEnum.AddSizeForElemName(MemSize, GetEnumName(LowType, i)); inc(i); end; un := FUnitName; if un = '' then un := '$u'; // must write some unitname TJitRttiWriterTkEnum.AddSizeForElemName(MemSize, un); TJitRttiWriterTkEnum.FinishSize(MemSize); SetFTypeInfo(AllocMem(MemSize + PtrRedirectMemSize)); PtrRedirectMem := Pointer(FTypeInfo) + MemSize; RttiWriterEnum := TJitRttiWriterTkEnum.Create(FTypeInfo, FTypeName, HighVal - LowVal + 1); i := LowVal; while i <= HighVal do begin RttiWriterEnum.WriteEnumElemName(GetEnumName(LowType, i)); inc(i); end; RttiWriterEnum.WriteMinMax(LowVal, HighVal); RttiWriterEnum.WriteUnitName(un); RttiWriterEnum.WriteBaseTypeRef(PTypeInfoToTypeInfoPtr(LowType, PtrRedirectMem)); assert(RttiWriterEnum.CurDestMemPos <= Pointer(FTypeInfo) + MemSize, 'DoSubRange: RttiWriterEnum.CurDestMemPos <= Pointer(FTypeInfo) + MemSize'); RttiWriterEnum.Free; RefCountedTypeInfo.AddToList(LowJitType); end; tkInteger, tkInt64, tkQWord: begin Signed := LowType^.Kind <> tkQWord; if not Signed then begin if (HighType^.Kind <> tkQWord) and (HighVal < 0) then begin if QWord(LowVal) > QWord(high(int64)) then raise JitTypeParserException.Create(TokenParser^.CurPos, '', 'range check error'); Signed := True; if (LowVal <= High(longint)) then begin // TODO: maybe downgrade if: and (HighVal >= low(LongInt)) => force tkInteger; LowType := HighType; // tkInteger or tkInt64 LowJitType := HighJitType; end else begin LowType := system.TypeInfo(Int64); LowJitType := nil; end; end; end else begin // LowType is Signed case HighType^.Kind of tkInt64: begin LowType := HighType; // LowType was either tkInt64 or tkInteger; LowJitType := HighJitType; end; tkQWord: begin if (LowVal < 0) then begin if QWord(HighVal) > QWord(high(int64)) then raise JitTypeParserException.Create(TokenParser^.CurPos, '', 'range check error'); Signed := True; if (HighVal > High(longint)) then begin LowType := system.TypeInfo(Int64); LowJitType := nil; end; end else begin LowType := HighType; // both QWord LowJitType := HighJitType; end; end; end; end; MemSize := TJitRttiWriterTypeInfo.NewSizeFor(FTypeName, LowType^.Kind); SetFTypeInfo(AllocMem(MemSize)); RttiWriterIntRange := TJitRttiWriterOrdinal.Create(FTypeInfo, FTypeName, LowType^.Kind); RttiWriterIntRange.WriteOrdType(HighVal - LowVal + 1, Signed); RttiWriterIntRange.WriteMinMax(LowVal, HighVal); RttiWriterIntRange.Free; RefCountedTypeInfo.AddToList(LowJitType); end; tkChar, tkWChar: begin if HighType <> LowType then raise JitTypeParserException.Create(TokenParser^.CurPos, '', 'Type mismatch between low and high bound'); MemSize := TJitRttiWriterTypeInfo.NewSizeFor(FTypeName, LowType^.Kind); SetFTypeInfo(AllocMem(MemSize)); RttiWriterIntRange := TJitRttiWriterOrdinal.Create(FTypeInfo, FTypeName, LowType^.Kind); RttiWriterIntRange.WriteOrdType(HighVal - LowVal + 1, False); RttiWriterIntRange.WriteMinMax(LowVal, HighVal); RttiWriterIntRange.Free; RefCountedTypeInfo.AddToList(LowJitType); end; //tkBool:; // TODO: else raise JitTypeParserException.Create(TokenParser^.CurPos, LowType^.Name, 'unexpected sub range type'); end; end; procedure DoArray; var TpUnit, TpName: String; ArrayTypeInfo: PTypeInfo; SubJitTypeInfo: TJitTypeInfo; TypeMemSize: Integer; PtrRedirectMem: Pointer; RttiWriter: TJitRttiWriterTkDynArray; IsEmbeddedTp: Boolean; tk: TJitParserTkKind; begin case TokenParser^.Next(pcOfExpexted) of kwOf: begin IsEmbeddedTp := True; tk := TokenParser^.Next; TokenParser^.SavePosition; if tk = ptIdent then begin TokenParser^.GetQualifiedIdent(TpUnit, TpName); if not TokenParser^.IsBeforeEotOrSectionEnd then begin IsEmbeddedTp := False; if TpUnit <> '' then ArrayTypeInfo := FindTypeInfo(TpName, True, TpUnit, [tsoOnlyUnit]) else ArrayTypeInfo := FindTypeInfo(TpName, True, FUnitName); end; end; if IsEmbeddedTp then begin TokenParser^.RestorePosition; SubJitTypeInfo := TJitTypeInfo.Create('', FDeclaration, FUnitName, TypeLibrary); SubJitTypeInfo.ParseFromDeclaration(TokenParser); ArrayTypeInfo := SubJitTypeInfo.FTypeInfo; // do not use property / do not scan again if nil RefCountedTypeInfo.AddToList(SubJitTypeInfo); SubJitTypeInfo.Free; end; AssertIsBeforeEOT(AParser <> nil); TypeMemSize := TJitRttiWriterTypeInfo.NewSizeFor(FTypeName, tkDynArray); SetFTypeInfo(AllocMem(TypeMemSize + SIZE_OF_TYPEINFO_PPOINTER)); PtrRedirectMem := Pointer(FTypeInfo) + TypeMemSize; // TODO: variant type info RttiWriter := TJitRttiWriterTkDynArray.Create(FTypeInfo, FTypeName, FUnitName, ArrayTypeInfo.DataSize, PTypeInfoToTypeInfoPtr(ArrayTypeInfo, PtrRedirectMem), -1); assert(RttiWriter.CurDestMemPos <= Pointer(FTypeInfo) + TypeMemSize, 'DoArray: RttiWriter.CurDestMemPos <= Pointer(FTypeInfo) + TypeMemSize'); RttiWriter.Free; end; //ptSquareOpen: ; else raise JitTypeParserExceptionSyntaxError.Create(TokenParser^.CurPos, TokenParser^.CurrentToken, 'Expected "of"'); // 'Expected "[" or "of"' end; end; var NewTypeInfo: PTypeInfo; s: String; tk, tk2: TJitParserTkKind; begin if FIsInParseFromDeclaration then exit; FIsInParseFromDeclaration := true; try Decl := FDeclaration; if AParser = nil then Decl := TrimDeclaration(Decl); if AParser <> nil then begin TokenParser := AParser; end else begin TheTokenParser.Create(@Decl[1]); TokenParser := @TheTokenParser; end; tk := TokenParser^.CurrentKind; case tk of ptRoundOpen: DoEnum; kwProcedure: DoProcedure(False); kwFunction: DoProcedure(True); kwRecord: DoRecord; kwSet: DoSet; kwArray: DoArray; else begin if (tk = kwString) and (TokenParser^.PeekKind() = ptSquareOpen ) then begin DoShortString; exit; end; s := TokenParser^.CurrentToken; if tk in [ptIdent, ptNum, ptChar] then begin tk2 := TokenParser^.PeekKind; if tk2 in [ptRoundOpen, ptDotDot, ptDot] then begin // subrange: value .. value OR TypeCast(value) .. DoSubRange(tk, s); exit; end; end; if tk <> kwString then // string may be added as an alias AssertIsIdent(tk, s); NewTypeInfo := FindTypeInfo(s, False); if IsBeforeEOT(AParser <> nil) and (NewTypeInfo <> nil) then begin if (LastIntTypeInfoFound <> nil) and (not LastIntTypeInfoFound.IsConstTypeInfo) then SetFTypeInfo(NewTypeInfo) else SetConstFTypeInfo(NewTypeInfo); RefCountedTypeInfo.AddToList(LastIntTypeInfoFound); exit; end; raise JitTypeParserExceptionTypeNotFound.Create(TokenParser^.CurPos, s, 'type not found') end; end; finally FIsInParseFromDeclaration := False; end; end; constructor TJitTypeInfo.Create(ATypeName, ADeclaration, AUnitName: String; ATypeLibrary: TJitTypeLibrary; AParseFlags: TJitTypeInfoParseFlags); begin inherited Create(ATypeName, AUnitName, ATypeLibrary); FDeclaration := ADeclaration; FParseFlags := AParseFlags; end; constructor TJitTypeInfo.Create(ATypeName, ADeclaration: String; ATypeLibrary: TJitTypeLibrary; AParseFlags: TJitTypeInfoParseFlags); begin Create(ATypeName, ADeclaration, '', ATypeLibrary, AParseFlags); end; constructor TJitTypeInfo.Create(ATypeName: String; ATypeInfo: PTypeInfo; ATypeLibrary: TJitTypeLibrary); begin SetConstFTypeInfo(ATypeInfo); inherited Create(ATypeName, ATypeLibrary); end; destructor TJitTypeInfo.Destroy; begin inherited Destroy; if FRefCountedTypeInfo <> nil then FRefCountedTypeInfo.ReleaseLock else if (FTypeInfo <> nil) and not FIsConstTypeInfo then Freemem(FTypeInfo); end; { TJitTypeClass } function TJitTypeClass.GetTypeInfo: PTypeInfo; begin Result := FClass.ClassInfo; end; function TJitTypeClass.GetJitClass: TClass; begin Result := FClass; end; constructor TJitTypeClass.Create(ATypeName: String; AClass: TClass; ATypeLibrary: TJitTypeLibrary); begin Create(ATypeName, AClass.UnitName, AClass, ATypeLibrary); end; constructor TJitTypeClass.Create(ATypeName, AUnitName: String; AClass: TClass; ATypeLibrary: TJitTypeLibrary); begin inherited Create(ATypeName, AUnitName, ATypeLibrary); FClass := AClass; end; { TJitTypeJitClass } procedure TJitTypeJitClass.DoCreatorFreed(Sender: TObject); begin FJitClassCreator := nil; end; function TJitTypeJitClass.GetTypeInfo: PTypeInfo; begin if FJitClassCreator <> nil then Result := FJitClassCreator.TypeInfo else Result := nil; end; function TJitTypeJitClass.GetJitClass: TClass; begin if FJitClassCreator <> nil then Result := FJitClassCreator.GetJitClass else Result := nil; end; function TJitTypeJitClass.GetLockReferenceInc: TRefCountedJitReference; begin if FJitClassCreator <> nil then Result := FJitClassCreator.LockReference else Result := nil; end; function TJitTypeJitClass.IsConstTypeInfo: Boolean; begin Result := False; end; constructor TJitTypeJitClass.Create(ATypeName: String; AJitClassCreator: TJitClassCreatorBase; ATypeLibrary: TJitTypeLibrary; ATakeOwnerShip: Boolean); begin Create(ATypeName, AJitClassCreator.ClassUnit, AJitClassCreator, ATypeLibrary, ATakeOwnerShip); end; constructor TJitTypeJitClass.Create(ATypeName, AUnitName: String; AJitClassCreator: TJitClassCreatorBase; ATypeLibrary: TJitTypeLibrary; ATakeOwnerShip: Boolean); begin inherited Create(ATypeName, AUnitName, ATypeLibrary); FJitClassCreator := AJitClassCreator; if FJitClassCreator <> nil then FJitClassCreator.AddFreeNotification(@DoCreatorFreed); FOwnJitCreator := ATakeOwnerShip; end; destructor TJitTypeJitClass.Destroy; begin inherited Destroy; if FJitClassCreator <> nil then begin FJitClassCreator.RemoveFreeNotification(@DoCreatorFreed); if FOwnJitCreator then FJitClassCreator.Free; end; end; { TJitTypeAlias } function TJitTypeAlias.GetRealType: TJitType; begin Result := FRealType; if Result <> nil then exit; if TypeLibrary = nil then exit; if FInGetRealType then raise Exception.Create('circular alias'); FInGetRealType := True; try Result := TypeLibrary[FRealTypeName]; finally FInGetRealType := False; end; end; procedure TJitTypeAlias.DoRealTypeFreed(Sender: TObject); begin FRealType := nil; FTypeName := ''; // no longer valid / do not look up a new type end; function TJitTypeAlias.GetTypeInfo: PTypeInfo; var RealType: TJitType; begin Result := nil; RealType := GetRealType; if RealType <> nil then begin Result := RealType.TypeInfo; exit; end; Result := TypeInfoByName(FRealTypeName); end; function TJitTypeAlias.GetLockReferenceInc: TRefCountedJitReference; var RealType: TJitType; begin RealType := GetRealType; if RealType <> nil then Result := GetRealType.LockReference else Result := nil; end; function TJitTypeAlias.IsConstTypeInfo: Boolean; var RealType: TJitType; begin RealType := GetRealType; if RealType <> nil then Result := GetRealType.IsConstTypeInfo else Result := inherited IsConstTypeInfo; end; function TJitTypeAlias.GetResolvedTypeName: String; var RealType: TJitType; begin RealType := GetRealType; if RealType <> nil then Result := GetRealType.ResolvedTypeName else Result := inherited ResolvedTypeName; end; constructor TJitTypeAlias.Create(ATypeName, ARealTypeName: String; ATypeLibrary: TJitTypeLibrary); begin FRealTypeName := ARealTypeName; inherited Create(ATypeName, ATypeLibrary); end; constructor TJitTypeAlias.Create(ATypeName: String; ARealType: TJitType; ATypeLibrary: TJitTypeLibrary); begin FRealType := ARealType; if FRealType <> nil then FRealType.AddFreeNotification(@DoRealTypeFreed); inherited Create(ATypeName, ATypeLibrary); end; destructor TJitTypeAlias.Destroy; begin inherited Destroy; if FRealType <> nil then FRealType.RemoveFreeNotification(@DoRealTypeFreed); end; { TJitTypeLibrary } procedure TJitTypeLibrary.DoTypeFreed(Sender: TObject); var i: Integer; begin i := FTypeMap.IndexOfData(TJitType(Sender)); if i < 0 then exit; FTypeMap.Delete(i); end; function TJitTypeLibrary.GetTypes(AName: String): TJitType; var i: Integer; begin Result := nil; i := FTypeMap.IndexOf(LowerCase(AName)); if i >= 0 then Result := FTypeMap.Data[i]; end; procedure TJitTypeLibrary.SetAllowDuplicates(AValue: Boolean); begin if FAllowDuplicates = AValue then Exit; FAllowDuplicates := AValue; case AValue of True: FTypeMap.Duplicates := dupAccept; False: FTypeMap.Duplicates := dupError; end; end; function TJitTypeLibrary.IndexOf(ATypeName, AnUnitName: String): Integer; var NoUnit: Integer; n: String; begin if AnUnitName = '' then begin Result := FTypeMap.IndexOf(ATypeName); exit; end; Result := FTypeMap.Count - 1; NoUnit := -1; while Result >= 0 do begin if (FTypeMap.Data[Result].TypeName = ATypeName) then begin n := FTypeMap.Data[Result].UnitName; if n = AnUnitName then exit else if (NoUnit < 0) and (n = '') then NoUnit := Result; end; dec(Result); end; Result := NoUnit; end; constructor TJitTypeLibrary.Create; begin FTypeMap := TTypeMap.Create; AllowDuplicates := True; end; destructor TJitTypeLibrary.Destroy; begin Clear; FTypeMap.Free; inherited Destroy; end; function TJitTypeLibrary.AddType(AType: TJitType; ATakeOwnerShip: Boolean ): TJitType; begin Result := AType; Result.AddFreeNotification(@DoTypeFreed); if (IndexOf(AType.TypeName, AType.UnitName) >= 0) then raise Exception.Create('Duplicate Type'); FTypeMap.Add(LowerCase(AType.TypeName), AType); if (AType.TypeLibrary = nil) or ATakeOwnerShip then AType.TypeLibrary := Self; if ATakeOwnerShip then AType.FOwnedByLibrary := True; end; function TJitTypeLibrary.AddType(ATypeName, ADeclaration: String; AForceNewJitTypeInfo: Boolean): TJitType; begin Result := AddType(ATypeName, ADeclaration, '', AForceNewJitTypeInfo); end; function TJitTypeLibrary.AddType(ATypeName, ADeclaration, AUnitName: String; AForceNewJitTypeInfo: Boolean): TJitType; begin if (IndexOf(ATypeName, AUnitName) >= 0) then raise Exception.Create('Duplicate Type'); if not AForceNewJitTypeInfo then begin Result := Self[ADeclaration]; if Result <> nil then begin Result := AddAlias(ATypeName, ADeclaration); exit; end; end; Result := TJitTypeInfo.Create(ATypeName, ADeclaration, AUnitName); Result.AddFreeNotification(@DoTypeFreed); FTypeMap.Add(LowerCase(ATypeName), Result); Result.TypeLibrary := Self; Result.FOwnedByLibrary := True; end; function TJitTypeLibrary.AddClass(ATypeName: String; AClass: TClass): TJitType; begin AddClass(ATypeName, AClass.UnitName, AClass); end; function TJitTypeLibrary.AddClass(ATypeName, AUnitName: String; AClass: TClass ): TJitType; begin if (IndexOf(ATypeName, AUnitName) >= 0) then raise Exception.Create('Duplicate Type'); Result := TJitTypeClass.Create(ATypeName, AUnitName, AClass); Result.AddFreeNotification(@DoTypeFreed); FTypeMap.Add(LowerCase(ATypeName), Result); Result.TypeLibrary := Self; Result.FOwnedByLibrary := True; end; function TJitTypeLibrary.AddJitClass(ATypeName: String; AJitClassCreator: TJitClassCreatorBase; ATakeCreatorOwnerShip: Boolean ): TJitType; begin if (IndexOf(ATypeName, AJitClassCreator.ClassUnit) >= 0) then raise Exception.Create('Duplicate Type'); Result := TJitTypeJitClass.Create(ATypeName, AJitClassCreator, Self, ATakeCreatorOwnerShip); Result.AddFreeNotification(@DoTypeFreed); FTypeMap.Add(LowerCase(ATypeName), Result); Result.FOwnedByLibrary := True; end; function TJitTypeLibrary.AddAlias(ATypeName, ARealTypeName: String): TJitType; begin Result := TJitTypeAlias.Create(ATypeName, ARealTypeName); Result.AddFreeNotification(@DoTypeFreed); FTypeMap.Add(LowerCase(ATypeName), Result); Result.TypeLibrary := Self; Result.FOwnedByLibrary := True; end; procedure TJitTypeLibrary.Remove(ATypeName: String; AnUnitName: String); procedure RemoveEntry(AnIdx: Integer; AJytTyp: TJitType); var owned: Boolean; begin owned := AJytTyp.FOwnedByLibrary and (AJytTyp.TypeLibrary = Self); if AJytTyp.TypeLibrary = Self then AJytTyp.TypeLibrary := nil; FTypeMap.Delete(AnIdx); if owned then AJytTyp.Free // TODO: Decrease RefCount ? else AJytTyp.RemoveFreeNotification(@DoTypeFreed); end; var i: Integer; JytTyp: TJitType; begin if AllowDuplicates or (AnUnitName <> '') then begin i := FTypeMap.Count - 1; while i >= 0 do begin JytTyp := FTypeMap.Data[i]; if (JytTyp.TypeName = ATypeName) and ( (AnUnitName = '') or (AnUnitName = JytTyp.UnitName) ) then RemoveEntry(i, JytTyp); dec(i); if i >= FTypeMap.Count then i := FTypeMap.Count - 1; end; end else begin i := FTypeMap.IndexOf(ATypeName); // bin search if sorted if i < 0 then exit; JytTyp := FTypeMap.Data[i]; RemoveEntry(i, JytTyp); end; end; procedure TJitTypeLibrary.Clear; var i: Integer; t: TJitType; begin for i := 0 to FTypeMap.Count - 1 do begin t := FTypeMap.Data[i]; t.RemoveFreeNotification(@DoTypeFreed); if t.FOwnedByLibrary and (t.TypeLibrary = Self) then t.Free; end; FTypeMap.Clear; end; function TJitTypeLibrary.FindType(const AName: String; AnUnitName: String; ASearchOptions: TTypeSearchOptions): TJitType; var i: Integer; FOtherUnitResult: TJitType; n, u: String; begin FOtherUnitResult := nil; n := LowerCase(AName); u := LowerCase(AnUnitName); for i := 0 to FTypeMap.Count - 1 do begin Result := FTypeMap.Data[i]; if LowerCase(Result.TypeName) <> n then continue; if (tsoOnlyUnit in ASearchOptions) and (LowerCase(Result.UnitName) <> u) then continue; if (AnUnitName <> '') and (u <> LowerCase(Result.UnitName)) and (FOtherUnitResult = nil) then FOtherUnitResult := Result else exit; end; Result := FOtherUnitResult; end; function TJitTypeLibrary.FindTypeForEnumElem(const AnEnumElem: String; AnUnitName: String; ASearchOptions: TTypeSearchOptions): TJitType; var x: Integer; begin Result := FindTypeForEnumElem(AnEnumElem, x, AnUnitName, ASearchOptions); end; function TJitTypeLibrary.FindTypeForEnumElem(const AnEnumElem: String; out AnEnumVal: Integer; AnUnitName: String; ASearchOptions: TTypeSearchOptions ): TJitType; var i, FOtherUnitEnumVal: Integer; t: PTypeInfo; FOtherUnitResult: TJitType; u: String; begin FOtherUnitResult := nil; FOtherUnitEnumVal := -1; u := LowerCase(AnUnitName); for i := 0 to FTypeMap.Count - 1 do begin Result := FTypeMap.Data[i]; if (not (tsoOnlyUnit in ASearchOptions)) or (LowerCase(Result.UnitName) = u) then begin t := Result.TypeInfo; if (t <> nil) and (t^.Kind = tkEnumeration) then begin AnEnumVal := GetEnumValue(Result.TypeInfo, AnEnumElem); if AnEnumVal >= 0 then begin if (AnUnitName <> '') and (u <> LowerCase(Result.UnitName)) and (FOtherUnitResult = nil) then begin FOtherUnitResult := Result; FOtherUnitEnumVal := AnEnumVal; end else exit; end; end; end; end; Result := FOtherUnitResult; AnEnumVal := FOtherUnitEnumVal; end; end.